diff -Nru rakudo-2018.02.1/debian/changelog rakudo-2018.03/debian/changelog --- rakudo-2018.02.1/debian/changelog 2018-02-28 16:17:12.000000000 +0000 +++ rakudo-2018.03/debian/changelog 2018-04-03 17:33:16.000000000 +0000 @@ -1,3 +1,21 @@ +rakudo (2018.03-1) unstable; urgency=medium + + * New upstream version 2018.03 + * control: update moarvm-dev and nqp dep versions (cme) + * control: update Vcs-Browser and Vcs-Git + * update copyright info (cme) + * add instructions about signature file in README.source + * refreshed patch + + -- Dominique Dumont Tue, 03 Apr 2018 19:33:16 +0200 + +rakudo (2018.02.1-3) unstable; urgency=medium + + * rules: run tests one at a time + * patch repl test (Closes: #880795) + + -- Dominique Dumont Tue, 20 Mar 2018 18:24:29 +0100 + rakudo (2018.02.1-2) unstable; urgency=medium * control: breaks and replaces rakudo-lib (Closes: #891693) diff -Nru rakudo-2018.02.1/debian/control rakudo-2018.03/debian/control --- rakudo-2018.02.1/debian/control 2018-02-28 16:17:12.000000000 +0000 +++ rakudo-2018.03/debian/control 2018-04-03 17:33:16.000000000 +0000 @@ -12,12 +12,12 @@ libreadline-dev, libtommath-dev, libuv1-dev, - moarvm-dev (>= 2018.02), - nqp (>= 2018.02), + moarvm-dev (>= 2018.03), + nqp (>= 2018.03), perl Standards-Version: 4.1.3 -Vcs-Browser: https://anonscm.debian.org/cgit/pkg-rakudo/pkg-rakudo.git -Vcs-Git: https://anonscm.debian.org/git/pkg-rakudo/pkg-rakudo.git +Vcs-Browser: https://salsa.debian.org/perl6-team/rakudo +Vcs-Git: https://salsa.debian.org/perl6-team/rakudo.git Homepage: http://rakudo.org/ Package: rakudo diff -Nru rakudo-2018.02.1/debian/copyright rakudo-2018.03/debian/copyright --- rakudo-2018.02.1/debian/copyright 2018-02-28 16:17:12.000000000 +0000 +++ rakudo-2018.03/debian/copyright 2018-04-03 17:33:16.000000000 +0000 @@ -20,8 +20,8 @@ Copyright: 2007-2018, The Perl Foundation. License: Artistic-2.0 -Files: src/core/Channel.pm -Copyright: } +Files: t/3rdparty/* +Copyright: 1991-2016, Unicode, Inc. License: Artistic-2.0 Files: tools/autounfudge.pl diff -Nru rakudo-2018.02.1/debian/patches/fix-test rakudo-2018.03/debian/patches/fix-test --- rakudo-2018.02.1/debian/patches/fix-test 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/debian/patches/fix-test 2018-04-03 17:33:16.000000000 +0000 @@ -0,0 +1,16 @@ +Description: Fix repl test + This should fix this flapping test by increasing the time-out. +Bug: https://github.com/rakudo/rakudo/issues/1257 +Bug-Debian: https://bugs.debian.org/880795 +Origin: https://github.com/rakudo/rakudo/issues/1257#issuecomment-373997566 +--- a/t/02-rakudo/repl.t ++++ b/t/02-rakudo/repl.t +@@ -229,7 +229,7 @@ + { + # REPL must not start, but if it does start and wait for input, it'll + # "hang", from our point of view, which the test function will detect +- doesn't-hang \(:w, $*EXECUTABLE, ++ doesn't-hang :10wait, \(:w, $*EXECUTABLE, + '--repl-mode=interactive', '-M', 'NonExistentModuleRT128595' + ), :out(/^$/), :err(/'Could not find NonExistentModuleRT128595'/), + 'REPL with -M with non-existent module does not start'; diff -Nru rakudo-2018.02.1/debian/patches/series rakudo-2018.03/debian/patches/series --- rakudo-2018.02.1/debian/patches/series 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/debian/patches/series 2018-04-03 17:33:16.000000000 +0000 @@ -0,0 +1 @@ +fix-test diff -Nru rakudo-2018.02.1/debian/README.source rakudo-2018.03/debian/README.source --- rakudo-2018.02.1/debian/README.source 2018-02-28 16:17:12.000000000 +0000 +++ rakudo-2018.03/debian/README.source 2018-04-03 17:33:16.000000000 +0000 @@ -8,6 +8,12 @@ dependency requirements are added to control file. (this requires cme and libconfig-model-dpkg-perl) +Building the package +-------------------- + +* copy the signature file in build area +* run gbp build-package + Why the strict runtime dependency on nqp ? ------------------------------------------ @@ -64,4 +70,4 @@ So it looks like hairy dependency should be improved. - -- Dominique Dumont , Mon, 25 Apr 2016 13:55:21 +0200 + -- domi , Wed, 4 Apr 2018 09:03:37 +0200 diff -Nru rakudo-2018.02.1/debian/rules rakudo-2018.03/debian/rules --- rakudo-2018.02.1/debian/rules 2018-02-28 16:17:12.000000000 +0000 +++ rakudo-2018.03/debian/rules 2018-04-03 17:33:16.000000000 +0000 @@ -14,6 +14,11 @@ #NQP_NEXT = $(shell nqp --version | perl -n -E 'my ($$y,$$m) = m/(2\d+)\.(\d+)/; if ($$m < 12) { $$m++} else {$$m=1;$$y++}; printf("%d.%02d\n",$$y,$$m);') MOARVM_NEXT = $(shell moar --version | perl -n -E 'my ($$y,$$m) = m/(2\d+)\.(\d+)/; if ($$m < 12) { $$m++} else {$$m=1;$$y++}; printf("%d.%02d\n",$$y,$$m);') +# By default, perl t/harness5 runs 6 tests in parallel. This is fine +# on powerful system but tends to mess up tests on mips or armhf. +export TEST_JOBS = 1 + + %: dh $@ diff -Nru rakudo-2018.02.1/docs/announce/2018.03.md rakudo-2018.03/docs/announce/2018.03.md --- rakudo-2018.02.1/docs/announce/2018.03.md 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/docs/announce/2018.03.md 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,149 @@ +# Announce: Rakudo Perl 6 compiler, Release #121 (2018.03) + +On behalf of the Rakudo development team, I’m very happy to announce the +March 2018 release of Rakudo Perl 6 #121. Rakudo is an implementation of +Perl 6 on the Moar Virtual Machine[^1]. + +This release implements the 6.c version of the Perl 6 specifications. +It includes bugfixes and optimizations on top of +the 2015.12 release of Rakudo. + +Upcoming releases in 2018 will include new functionality that is not +part of the 6.c specification, available with a lexically scoped +pragma. Our goal is to ensure that anything that is tested as part of the +6.c specification will continue to work unchanged. There may be incremental +spec releases this year as well. + +The tarball for this release is available from . + +Please note: This announcement is not for the Rakudo Star +distribution[^2] — it’s announcing a new release of the compiler +only. For the latest Rakudo Star release, see +. + +The changes in this release are outlined below: + +New in 2018.03: + + SPECIAL NOTES: + + Str.comb(Regex) was fixed to return a Seq instead of a List, + making Str.comb always return a Seq. Code relying on the + specifics of the previous behavior might require some tweaks. + + Fixes: + + Fixed various sleep() issues [e3c4db73] + + Fixed <0/0> to be False [748d1a57] + + Improved Test.pm6's like/unlike [7c1a6cac] + + Fixed failure to sink last statements of `for` loops [4c5b81fe] + + Removed unneeded candidates in &say and ¬e [3a0d53ce] + + Made Str.comb(Regex) return a Seq [1da07530] + + Fixed &say and ¬e to not auto-thread [b62e0eb7][355b2eb5] + + Differentiated precomp NC sub setup markers [b27c548f][ec5edcae] + + Moved chrs() logic to List.chrs and made chrs() the gateway [1894eace] + + Moved ords() logic to Str.ords [61176475] + + Fixed bug on ops with subclasses of Range [440fceac] + + Fixed wrong assumption of Junction execution order [207313be] + [89f33bbe][e9cff795] + + Fixed cases of mis-scoped QAST::Block of regexes [fb882d49] + + Fixed .grep(Regex) on Hyper/Race Seqs [5e462e12] + + Fixed &dd to not mark Failures as handled [7773c3d5][65874b15] + + Enabled native-int candidates in bitshift operators [29fdb75a][3d735975] + + Made Int:D (elem) Range:D be independent of size of Range [de30c162] + + Straightened up `$/` handling in Str.subst[-mutate] [874fcdda] + + Fixed Metamodel shortname assignments [ce08683f] + + Fixed Pair.clone [5031dab3] + + Improved Pod::To::Text to indent tables [57af8b84][dffbd68a] + + Fixed precomp files of NativeCall users having absolute paths [51c4d4d8] + + Made sure `samewith`-using routines aren't inlined [e12e305a] + + Made sure MERGESORT-* don't leak low-level types [511bec0a] + + Fixed code generation bug affecting private methods calls in roles + where the target private method used a role parameter [21997b62] + + Various improvements to produced messages [a4f9090e][235d3f1c] + [3b350739][5ae1bbe1][52176c3c] + + Additions: + + Implemented IO::CatHandle.handles [d5baa036][eb064922][639c6da0] + + Made signal handlers cancellable [db010b84][a31579c7] + + “datagram”-oriented API for UDP sockets [67f36e36][b406b320][dd2c9019] + + Added support for replacement and strict setting in Buf.decode [0d796fb0] + + Added support to Encoding::Decoder to use replacements [ea92f550] + + Removals: + + Removed no longer used DELETEKEY helper sub [6f2cbcf7] + + Removed Range.clone-with-op [440fceac] + + Efficiency: + + Optimized Uni.list to reify 15x faster (on 10000-char str) [8b7385d8] + + Made Str.perl 43x faster for some chars [ba6b84bd] + + Optimized Str.perl by making uniprop(Int, Str) 2.7x faster [6ac56cc0] + + Made Rational.Str 28% faster [008b9279] + + Made internal RETURN-LIST sub faster for common case [3a4056bf] + + Made Num.Bool 9x faster [2a42cdbb] + + Nano-optimized supervisor thread sleep [4617976d][85ad0eba] + + Added special cases for 2-tuple infix:<,> that are 10% faster [b6e5d7fc] + [48c46fa7][90079357][ddf00078][d5a148c0] + + Made Channel.receive/receive-nil-on-close 2.5% faster [4054ca68] + + Reduced the number of DYNAMIC calls when hypering [598832cc] + + Made Channel.poll 2x fast [eff92f94] + + Made HyperIteratorBatcher.produce-batch 3.6x faster [8026cef8] + + Many HyperToIterator speedups [0194ef46][6232d29e][34889beb] + + Internal: + + Turned many subs into multis [16b57af5][55bc053c][182b7ea5][63775474] + [c2d0d3ac][cdb45fa5][4f473867][bf5e3357][5210d702][b704a175][4c67498f] + [7d72387b][838782b7][abfbd1ab][6d6a69fd][c1d2a5bc][4da2418a][62fc3118] + [d3f50dba][b9f40fea][dfef8283][9a0a7bdd][32b08035][51fccdfe][474c512c] + [4f04698f][423e7cc0][ae4204c5][8cba0846][1b94ff6f][5490bacd][e1b711ae] + [a23684f3][804c009a][f5b23a55][4513c279] + + Marked many subs as “only” [1be26afb][25bedf88] + + Marked set ops as “pure” on their proto only [af353894] + + Made Unicode operators aliases of corresponding ASCII subs [254f477e] + [aadd3c12][bc52fefa][a2100ec7][2e7a0e59] + + Added nqp::getppid [fed92e3b] + + Many profiler improvements, it now supports multi-threaded programs + [fed92e3b][a5a6c778][dd2c9019] + + Made substr() just a front for Str.substr [7835652d][b688a6f3][15ccfd33] + + Made substr-rw() just a front for Str.substr-rw [038837f8] + + Moved substr/substr-rw catcher methods from Any to Cool [aad79f8a] + + Remote debug support on MoarVM [ffeff74e][e32bda21] + + +The following people contributed to this release: + +Zoffix Znet, Elizabeth Mattijsen, JJ Merelo, Will "Coke" Coleda, +Paweł Murias, Christian Bartolomäus, Tom Browder, +Aleks-Daniel Jakimenko-Aleksejev, Luca Ferrari, Timo Paulssen, cfa, +Jonathan Worthington, Itsuki Toyota, Samantha McVey, Daniel Green, +Jan-Olof Hendig, Ronald Schmidt, Nick Logan, Stefan Seifert, +Richard Hainsworth, Steve Mynott, Ben Davies, Jeremy Studer, +Juan Julián Merelo Guervós, Patrick Spek, Alex Chen, Antonio Quinonez, +Brad Gilbert, Wenzel P. P. Peppmeyer, Brian S. Julin, LLFourn, Larry Wall + +If you would like to contribute or find out more information, visit +, , ask on the + mailing list, or ask on IRC #perl6 on freenode. + +Additionally, we invite you to make a donation to The Perl Foundation +to sponsor Perl 6 development: +(put “Perl 6 Core Development Fund” in the ‘Purpose’ text field) + +The next release of Rakudo (#122), is tentatively scheduled for 2018-04-21. + +A list of the other planned release dates is available in the +“docs/release_guide.pod” file. + +The development team appreciates feedback! If you’re using Rakudo, do +get back to us. Questions, comments, suggestions for improvements, cool +discoveries, incredible hacks, or any other feedback – get in touch with +us through (the above-mentioned) mailing list or IRC channel. Enjoy! + +Please note that recent releases have known issues running on the JVM. +We are working to get the JVM backend working again but do not yet have +an estimated delivery date. + +[^1]: See + +[^2]: What’s the difference between the Rakudo compiler and the Rakudo +Star distribution? + +The Rakudo compiler is a compiler for the Perl 6 language. +Not much more. + +The Rakudo Star distribution is the Rakudo compiler plus a selection +of useful Perl 6 modules, a module installer, Perl 6 introductory +documentation, and other software that can be used with the Rakudo +compiler to enhance its utility. diff -Nru rakudo-2018.02.1/docs/archive/2018-03-04--Polishing-Rationals.md rakudo-2018.03/docs/archive/2018-03-04--Polishing-Rationals.md --- rakudo-2018.02.1/docs/archive/2018-03-04--Polishing-Rationals.md 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/docs/archive/2018-03-04--Polishing-Rationals.md 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,324 @@ +# Polishing Rationals + +Mar. 4, 2018 proposal by Zoffix + +## Revision #3 + +Previous revisions: [rev. 2](https://github.com/rakudo/rakudo/blob/5feb6bbec3582831b3daef39b027597040ff5a92/docs/archive/2018-03-04--Polishing-Rationals.md) +[rev. 1](https://github.com/rakudo/rakudo/blob/a918028e058fd39646a5f24e1734d69821d67469/docs/archive/2018-03-04--Polishing-Rationals.md) + +## Executive Summary + +1. Implement `MidRat` and `MidRatStr` types. A `MidRat` is a `Rat`/`FatRat` + allomorph. It has the precision of a `FatRat`, but is has infectiousness + of a `Rat`. `MidRatStr` is the `MidRat`/`Str` allomorph. +2. `Rat` literals with denominators over 64-bit to be returned as a `MidRat` +3. If `Rat.new` is called with denominator that is (after reduction) over + 64-bit, construct a `MidRat` instead +4. Cases that currently create a `RatStr` with denominators over 64-bit + will return `MidRatStr` instead. +5. Remove the optimization that requires the use of `.REDUCE-ME` method, as + the optimization has bugs, race conditions, and is detrimental in many + cases. Preliminary testing (with some new optimizations) showed an 8% improvement in performance, so we're still getting a win here. +6. Always normalize zero-denominator Rationals to `<1/0>`, `<-1/0>`, and `<0/0>` + - Try mixing in `ZeroDenominatorRational` role into these to get + performance boost in operators (in dispatch). If improvement is low, + don't implement this part (the role mixing). + +## Crude Trial Implementation + +A trial implementation that partially implements `MidRat`/`MidRatStr` +is available in [`ratlab-fattish-rat` branch](https://github.com/rakudo/rakudo/tree/ratlab-fattish-rat) + +# TABLE OF CONTENTS +- [Problems Being Addressed](#problems-being-addressed) +- [1) Eliminate edge-cases that produce `Rat`s with denominators above 64-bit](#1-eliminate-edge-cases-that-produce-rats-with-denominators-above-64-bit) + - [I propose:](#i-propose) + - [Reasoning](#reasoning) + - [Discarded Ideas](#discarded-ideas) +- [2) Make `Rational`s fully-immutable to avoid data-races](#2-make-rationals-fully-immutable-to-avoid-data-races) + - [1) Data Race](#1-data-race) + - [2) Inconsistent Object Identity](#2-inconsistent-object-identity) + - [3) Limited Usefulness of the Optimization](#3-limited-usefulness-of-the-optimization) + - [I propose:](#i-propose-1) +- [3) Fix bugs with operations on zero-denominator `Rational`s](#3-fix-bugs-with-operations-on-zero-denominator-rationals) + - [I propose:](#i-propose-2) + +## Problems Being Addressed + +1) Eliminate edge-cases that produce `Rat`s with denominators above 64-bit ([RT#132313](https://rt.perl.org/Public/Bug/Display.html?id=132313#ticket-history)) +2) Make `Rational`s fully-immutable to avoid data-races ([RT#130774](https://rt.perl.org/Ticket/Display.html?id=130774#ticket-history)) +3) Fix bugs with operations on zero-denominator `Rational`s ([R#1354](https://github.com/rakudo/rakudo/issues/1354)) + +## 1) Eliminate edge-cases that produce `Rat`s with denominators above 64-bit + +Under normal conditions, and if `FatRat`s are not involved, if a `Rat`-producing operation were to make a `Rat` with a denominator larger than 64-bit, the result is a `Num` instead: + +```perl-6 + say 1/48112959837082048697; # OUTPUT: «2.07844207337515e-20» +``` + +However, currently it's possible to create a `Rat` with denominators over +64-bit using `val`, quote words, `Rat` literal syntax, or `Rat.new` method call: + +```perl-6 + say [.^name, $_, .nude, .denominator.log: 2] + with (val "1/48112959837082048697").Numeric; + # [Rat 0.000000000000000000021 (1 48112959837082048697) 65.3830593574438] + + say [.^name, $_, .nude, .denominator.log: 2] with <1/48112959837082048697>; + # [Rat 0.000000000000000000021 (1 48112959837082048697) 65.3830593574438] + + say [.^name, $_, .nude, .denominator.log: 2] + with Rat.new: 1, 48112959837082048697; + # [Rat 0.000000000000000000021 (1 48112959837082048697) 65.3830593574438] + + say [.^name, $_, .nude, .denominator.log: 2] with 1.111111111111111111111 + # [Rat 1.11111111111111111604544 (1111111111111111111111 1000000000000000000000) 69.7604899926346] +``` + +As can be seen from the last example above, there is loss of precision involved in some routines when working with such `Rats`. + +### **I propose:** + + +1. Implement `MidRat` and `MidRatStr` types. A `MidRat` is a `Rat`/`FatRat` + allomorph. It has the precision of a `FatRat`, but is has infectiousness + of a `Rat`. `MidRatStr` is the `MidRat`/`Str` allomorph. +2. `Rat` literals with denominators over 64-bit are returned as a `MidRat` +3. If `Rat.new` is called with denominator that is (after reduction) over 64-bit, construct a `MidRat` instead +4. Cases that currently create a `RatStr` with denominators over 64-bit + will return `MidRatStr` instead. + +### Reasoning + +1. The new system makes the `Rat` literals be `Rational` literals, with + precision handling based on how much precision the user provided. +3. While it may be somewhat unusual for `Rat.new` to create a type that isn't + a `Rat`, I believe creating a `MidRat` instead of throwing is more user-friendly, as it can be hard to discern whether the denominator would fit, especially because the fit-test is done **after** reduction. For example, try guessing which of this would fit into a Rat: + +```perl-6 + Rat.new: 48112959837032048697, 48112959837082048697 + + Rat.new: 680564733841876926926749214863536422912, + 1361129467683753853853498429727072845824 +``` + +The first one would end up as a `MidRat` with it's 66-bit denominator, +while the second one becomes a `Rat` with value `0.5` after reduction. + +### Discarded Ideas + +These are the alternatives I (and others) have considered and found inadequate. + +- *Discarded Idea #-1:* Make `RatStr` a non-infectious `FatRat` able to + handle the extra precision. + + This is the idea in [rev. 2](https://github.com/rakudo/rakudo/blob/5feb6bbec3582831b3daef39b027597040ff5a92/docs/archive/2018-03-04--Polishing-Rationals.md), however: + it feels a lot like abuse of a type for things it wasn't meant to be: + - This idea means typing `my Str $x = 1.1111111111111111111` is a + typecheck error, but typing `my Str $x = 1.11111111111111111111` is all OK. It feels very weird to me that we switch to producing `Str` + subclasses from numeric literals. + - This idea means we either have to lug around an additional `Int` + denominator in all `RatStr` types and somehow make it available whenever + the object is used as a `Rational` or make their performance a lot + slower, as we'd be re-parsing the `Str` portion to extract + high-precision denominator + - This idea means when presented with a `RatStr`, we've no real idea + whether it actually contains high-precision data. + +- *Discarded Idea #0:* Create a `FatRat` instead of a `Rat` in cases where + we currently create a broken `Rat` + + This is the idea in [rev. 1](https://github.com/rakudo/rakudo/blob/a918028e058fd39646a5f24e1734d69821d67469/docs/archive/2018-03-04--Polishing-Rationals.md) of this proposal, + but [further discussion](https://irclog.perlgeek.de/perl6-dev/2018-03-05#i_15887340) + showed it would be more useful to have an equivalent of a non-infectious + `FatRat` to, for example, facilitate extra precision in `π` and `e` + constants without forcing the use of the infectious `FatRat` type for them. + +- *Discarded Idea #1:* All of problematic cases to produce a `Num` (or `NumStr`) + + While this avoids creating a new type it creates a problem that the user might get a type that isn't `Rational` by just adding a single digit: + And that also means that when the user **explicitly gives us more + precision** in their literals, we discard it and give a type that's less + precise than even a plain `Rat`: + + ```perl-6 + my Rat $x = 4.9999999999999999999; # OK + my Rat $x = 4.99999999999999999999; # Typecheck failure: Got Num + + say 4.999999999999999999999999999999999999999999999999999999999999999999 ~~ ^5; + # (would produce "False") + ``` + +- *Discarded Idea #2:* Make literals produce `FatRat` and val/quotewords produce `RatStr` that can be either `FatRat` or `Rat` in the numeric portion. + + *(N.B.: unlike current version of the proposal, in this scenario + a fatty `RatStr` behaves like an* **infectious** *`FatRat`)* + + This creates a problem with infectiousness in that, say `Num` + `RatStr` + produce a `Num`. In a scenario where `RatStr` could contain a `FatRat` as + a numeric, the operation would be expected to produce a `FatRat` as a + result. Even if this is made to work, it would be unpredictable behaviour, + as you can't tell by type alone what result you'd receive. + +- *Discarded Idea #3:* Introduce non-infectious FatRat type + + This would also require an allomorphic counterpart and I'm a bit worried + about the increase in operators to handle such a type. And if you're making + this type lose precision with operations with other types, may as well + not have it have that precision available in the first place. + +## 2) Make `Rational`s fully-immutable to avoid data-races + +Current implementation of `Rational` contains an optimization used by certain operators, e.g. `infix:<+>`: if we can perform the operation without needing +to change the denominator, then we save time by avoiding reduction and merely produce an **un-reduced Rational** with a tweaked numerator. Thus, for example, +instead of `<1/1>`, `½ + ½` gives `<2/2>`: + + say [.numerator, .denominator] with ½ + ½; + # [2 2] + +A private `.REDUCE-ME` method is then used to cheat around that optimization +and methods that need a reduced rational call it: + + say .nude with ½ + ½; + # (1 1) + +This approach has three problems: + +### 1) **Data Race** + +The worst issue is a rare data race. Since `.REDUCE-ME` **mutates** the +`Rational` object and some operations read the numerator/denominator without +reduction, it's possible for an operation in one thread (say `infix:<+>`) to +read off the numerator, then for another thread to mutate numerator and +denominator, and then for the first thread to read the denominator that no +longer corresponds to the numerator that was read. + +The following code reproduces the race, and once in a while dies with +`Died with the exception: Not right [2] (denominator 2 numerator 2)`: +indicating that mathematical operation `½ + ½ + ½` resulted in answer `1`. +Imagine the look on CFO's face when they find out a $1.5M profit somehow ended +up being just $1M. + +```perl-6 + use v6.d.PREVIEW; + for ^20000 { + await ^10 .map: { start { + my $r := ½ + rand.ceiling/2; + my $at := now + .003; + await Promise.at($at).then({ + $r.nude; + $r.numerator == $r.denominator == 1 + or die "Not right [1] ($r.Capture())"; + }), + Promise.at($at).then({ + my $r2 := $r + ½; + $r2.numerator == 3 and $r2.denominator == 2 + or die "Not right [2] ($r2.Capture())"; + }) + }} + } +``` + +### 2) **Inconsistent Object Identity** + +Since `Rational`s are a value type, the following answer makes sense: + +```perl-6 + say ½+½ === 1/1; + # True +``` + +The two resultant `Rational`s are of the same type and have the same value, +and thus are the same object. Object identity is used by `Set`s and related +types, so we'd expect the two objects above, when placed into a `Set`, to +be counted as one item, however they don't: + +```perl-6 + say set(½+½, 1/1).perl; + # Set.new(1.0,<1/1>) +``` + +The aforementioned `.REDUCE-ME` must be called by everything that has to +operate on a reduced rational. We already fixed several bugs where methods +did not do so, and the above example is just one more in that bunch. Even the +output of `.perl`—which doesn't need to use `.REDUCE-ME`—is affected +by the presence of this optimization. + +### 3) **Limited Usefulness of the Optimization** + +The aforementioned optimization that produces unreduced rationals is only +beneficial if those operations are vastly more common than any other operation +that has to use `.REDUCE-ME` as a result. I believe that assumption is too +narrow in scope and in many cases is actually detrimental. + +First, if we remove this optimization, reduction would have to be done precisely +once and only when it's needed. With the optimization, however, we have to +go through `.REDUCE-ME` routine multiple times, even if we no reduction needs +to be done. Thus, code like this… + + my $r := ½ + ½; + my $ = $r.narrow for ^5000_000; + +…is 4.65x **SLOWER** when the optimization is in place than when it isn't. + +The impact is felt even in routines that don't have to call `.REDUCE-ME`, such +as `.floor`: + + my $r := ½ + ½; + my $ = $r.floor for ^5000_000; + +The above construct becomes 10% faster if we reduce the rational *before* going +into the `for` loop, thanks to the fast-path on `$!denominator == 1` in the +`.floor` routine. While that may seem trivial, `.floor` is actually used +*multiple times* by each `.Str` call, and so this… + + my $r := ½ + ½; + my $ = $r.Str for ^500_000; + +…becomes 15% faster if reduction is performed during addition. + +------ + +As can be seen, even if all of the bugs and race conditions were addressed, +the detrimental impact of this optimization is far-reaching, while the +beneficial aspect is rather narrow. Certainly, an accounting software that +sums up the totals of last month's thousands of purchases can benefit from +`infix:<+>` not performing reduction, but is that that common case? Or would +faster `.Str`, `.narrow`, and dozens of other methods +be of more benefit to a multitude of programs in other domains. + +### **I propose:** + +I propose we address the issues above by simply removing this optimization +altogether. + +I've performed preliminary testing using a bench that calls all Rational methods enough times for each method's bench to run for 1 second. When running all the +benches together (thus, having some GC runs), with **removed** `REDUCE_ME` +optimization and a couple of new optimizations applied, I was able to get +the bench to run **8% faster**. So, I think after this proposal is +fully-implemented, we'll see some performance wins, not losses. + +## 3) Fix bugs with operations on zero-denominator `Rational`s + +The bugs are largely due to numerators being arbitrary numbers, yet being +computed as if they were normal Rationals. So `<3/0> - <5/0>` (`Inf - Inf`) +ends up being `<-2/0>` (`-Inf`), but it must become a `<0/0>` (`NaN`). + +### **I propose:** + +My primary proposal is for zero-denominator `Rational`s to be normalized to +`<1/0>`, `<-1/0>`, and `<0/0>`. I think doing that alone will fix all the +bugs in all the routines (tests that'll be written will show that). If it +won't, the still-broken cases will be tweaked in specific routines on a +case-by-case basis. + +My secondary proposal is to implement an essentially empty role +`ZeroDenominatorRational` that will be used to tag zero-denominator +`Rationals` and the ops that have special-handling for zero-denominator +`Rationals` would move that handling into a separate multi candidate dispatched +on that role. The hope here is to get a sizeable performance improvement by not +having to do extra checks for zero-denominator Rationals in common operators. +If it'll turn out the performance improvement this idea brings is +insignificant, this proposal will not be implemented. diff -Nru rakudo-2018.02.1/docs/ChangeLog rakudo-2018.03/docs/ChangeLog --- rakudo-2018.02.1/docs/ChangeLog 2018-02-23 05:08:43.000000000 +0000 +++ rakudo-2018.03/docs/ChangeLog 2018-03-19 11:27:21.000000000 +0000 @@ -1,3 +1,81 @@ +New in 2018.03: + + SPECIAL NOTES: + + Str.comb(Regex) was fixed to return a Seq instead of a List, + making Str.comb always return a Seq. Code relying on the + specifics of the previous behavior might require some tweaks. + + Fixes: + + Fixed various sleep() issues [e3c4db73] + + Fixed <0/0> to be False [748d1a57] + + Improved Test.pm6's like/unlike [7c1a6cac] + + Fixed failure to sink last statements of `for` loops [4c5b81fe] + + Removed unneeded candidates in &say and ¬e [3a0d53ce] + + Made Str.comb(Regex) return a Seq [1da07530] + + Fixed &say and ¬e to not auto-thread [b62e0eb7][355b2eb5] + + Differentiated precomp NC sub setup markers [b27c548f][ec5edcae] + + Moved chrs() logic to List.chrs and made chrs() the gateway [1894eace] + + Moved ords() logic to Str.ords [61176475] + + Fixed bug on ops with subclasses of Range [440fceac] + + Fixed wrong assumption of Junction execution order [207313be] + [89f33bbe][e9cff795] + + Fixed cases of mis-scoped QAST::Block of regexes [fb882d49] + + Fixed .grep(Regex) on Hyper/Race Seqs [5e462e12] + + Fixed &dd to not mark Failures as handled [7773c3d5][65874b15] + + Enabled native-int candidates in bitshift operators [29fdb75a][3d735975] + + Made Int:D (elem) Range:D be independent of size of Range [de30c162] + + Straightened up `$/` handling in Str.subst[-mutate] [874fcdda] + + Fixed Metamodel shortname assignments [ce08683f] + + Fixed Pair.clone [5031dab3] + + Improved Pod::To::Text to indent tables [57af8b84][dffbd68a] + + Fixed precomp files of NativeCall users having absolute paths [51c4d4d8] + + Made sure `samewith`-using routines aren't inlined [e12e305a] + + Made sure MERGESORT-* don't leak low-level types [511bec0a] + + Fixed code generation bug affecting private methods calls in roles + where the target private method used a role parameter [21997b62] + + Various improvements to produced messages [a4f9090e][235d3f1c] + [3b350739][5ae1bbe1][52176c3c] + + Additions: + + Implemented IO::CatHandle.handles [d5baa036][eb064922][639c6da0] + + Made signal handlers cancellable [db010b84][a31579c7] + + “datagram”-oriented API for UDP sockets [67f36e36][b406b320][dd2c9019] + + Added support for replacement and strict setting in Buf.decode [0d796fb0] + + Added support to Encoding::Decoder to use replacements [ea92f550] + + Removals: + + Removed no longer used DELETEKEY helper sub [6f2cbcf7] + + Removed Range.clone-with-op [440fceac] + + Efficiency: + + Optimized Uni.list to reify 15x faster (on 10000-char str) [8b7385d8] + + Made Str.perl 43x faster for some chars [ba6b84bd] + + Optimized Str.perl by making uniprop(Int, Str) 2.7x faster [6ac56cc0] + + Made Rational.Str 28% faster [008b9279] + + Made internal RETURN-LIST sub faster for common case [3a4056bf] + + Made Num.Bool 9x faster [2a42cdbb] + + Nano-optimized supervisor thread sleep [4617976d][85ad0eba] + + Added special cases for 2-tuple infix:<,> that are 10% faster [b6e5d7fc] + [48c46fa7][90079357][ddf00078][d5a148c0] + + Made Channel.receive/receive-nil-on-close 2.5% faster [4054ca68] + + Reduced the number of DYNAMIC calls when hypering [598832cc] + + Made Channel.poll 2x fast [eff92f94] + + Made HyperIteratorBatcher.produce-batch 3.6x faster [8026cef8] + + Many HyperToIterator speedups [0194ef46][6232d29e][34889beb] + + Internal: + + Turned many subs into multis [16b57af5][55bc053c][182b7ea5][63775474] + [c2d0d3ac][cdb45fa5][4f473867][bf5e3357][5210d702][b704a175][4c67498f] + [7d72387b][838782b7][abfbd1ab][6d6a69fd][c1d2a5bc][4da2418a][62fc3118] + [d3f50dba][b9f40fea][dfef8283][9a0a7bdd][32b08035][51fccdfe][474c512c] + [4f04698f][423e7cc0][ae4204c5][8cba0846][1b94ff6f][5490bacd][e1b711ae] + [a23684f3][804c009a][f5b23a55][4513c279] + + Marked many subs as “only” [1be26afb][25bedf88] + + Marked set ops as “pure” on their proto only [af353894] + + Made Unicode operators aliases of corresponding ASCII subs [254f477e] + [aadd3c12][bc52fefa][a2100ec7][2e7a0e59] + + Added nqp::getppid [fed92e3b] + + Many profiler improvements, it now supports multi-threaded programs + [fed92e3b][a5a6c778][dd2c9019] + + Made substr() just a front for Str.substr [7835652d][b688a6f3][15ccfd33] + + Made substr-rw() just a front for Str.substr-rw [038837f8] + + Moved substr/substr-rw catcher methods from Any to Cool [aad79f8a] + + Remote debug support on MoarVM [ffeff74e][e32bda21] + New in 2018.02.1: + Fixes: + Fixed Whatever curry QAST::Block migration in stmt mods [5270471c] diff -Nru rakudo-2018.02.1/docs/obtaining-a-commit-bit.pod rakudo-2018.03/docs/obtaining-a-commit-bit.pod --- rakudo-2018.02.1/docs/obtaining-a-commit-bit.pod 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/docs/obtaining-a-commit-bit.pod 2018-03-19 11:27:21.000000000 +0000 @@ -2,22 +2,26 @@ Firstly, what's a "commit bit"? If you don't know what it is, you probably don't need one :-) But, in any case, a "commit bit" is the -colloquial way that #perl6 describes how you obtain access to make -commits directly to the rakudo repository. (i.e., not via a fork and -pull request, but directly to https://github.com/rakudo/rakudo) +colloquial way that L<#perl6|https://webchat.freenode.net/?channels=#perl6> +describes how you obtain access to make commits directly to the rakudo +repository. (i.e., not via a fork and pull request, but directly +to https://github.com/rakudo/rakudo) -Step one, if you haven't already, is to send a signed copy of the -Contributor License Agreement (CLA) to the Perl Foundation. The CLA can +B if you haven't already, is to send a signed copy of the +Contributor License Agreement (CLA) to the Perl Foundation. The CLA and the +address it can be mailed to can be found at http://www.perlfoundation.org/contributor_license_agreement +Some contributors chose to email the CLA to C +instead; you can speak to C<[Coke]> on +L for details about +the process as well as follow up on whether your CLA has been received by +The Perl Foundation. -Why is a signed CLA necessary for commit access? Historically, it is -because Rakudo used to be part of the Parrot project and that project -required a signed CLA. But the reasons that Parrot required a CLA are -also valid for Rakudo. That is, the CLA helps protect the Perl +Why is a signed CLA necessary for commit access? The CLA helps protect the Perl Foundation and the Rakudo project and contributors alike from intellectual property issues. The CLA warrants that your contributions are yours to give and that they are not encumbered by anyone else's -intellectual "lien" on those contributions. +intellectual "lien" on those contributions. For instance, some employment contracts stipulate that any intellectual property that you generate belongs to your employer whether you generate @@ -28,8 +32,10 @@ CLA says that you have done the due diligence in these matters and that as far as you are aware, your contributions are yours alone to give. -Once you send off your signed CLA, you can then inquire on -irc://freenode.net/#perl6 about getting commit access to the Rakudo +B and it's received by The Perl Foundation +you can then inquire on +L +about getting commit access to the Rakudo repository. The main source code repository for Rakudo is administered on GitHub, so it would be a good idea to have a github account before you request a commit bit. There is at least one officer of the Perl diff -Nru rakudo-2018.02.1/docs/release_guide.pod rakudo-2018.03/docs/release_guide.pod --- rakudo-2018.02.1/docs/release_guide.pod 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/docs/release_guide.pod 2018-03-19 11:27:21.000000000 +0000 @@ -18,8 +18,7 @@ compatibility issues post Christmas. As such, we may end up delaying some releases to ensure any compatibility issues are resolved. - 2018-03-17 Rakudo #121 (AlexDaniel + Releasable) - 2018-04-21 Rakudo #122 + 2018-04-21 Rakudo #122 (AlexDaniel + Releasable) 2018-05-19 Rakudo #123 2018-06-16 Rakudo #124 2018-07-21 Rakudo #125 @@ -77,13 +76,13 @@ git add docs/announce/YYYY.MM.md git commit docs -There is a helper script C that +There is a helper script C that will create a basic release announcement for you based on the state of the repository and the current date. Feel free to use it to save yourself some time, but please look over its output if you decide to use it: - ./perl6 tools/create-release-announcement.pl6 > docs/announce/YYYY.MM.md + ./perl6 tools/create-release-announcement.p6 > docs/announce/YYYY.MM.md =item * @@ -133,7 +132,7 @@ Include a list of contributors since the last release in the announcement. You can get an automatically generated list by running - ./perl6 tools/contributors.pl6 + ./perl6 tools/contributors.p6 To obtain all contributors, ensure you have all supporting repositories checked out, before running (this can be achieved by building rakudo @@ -448,6 +447,7 @@ 2018-01-25 Rakudo #119 "2018.01" (AlexDaniel + Releasable) 2018-02-20 Rakudo #120 "2018.02" (AlexDaniel + Releasable) 2018-02-23 2018.02.1 (AlexDaniel + Releasable) + 2018-03-19 Rakudo #121 "2018.02" (AlexDaniel + Releasable) =head1 COPYRIGHT diff -Nru rakudo-2018.02.1/lib/CompUnit/Repository/Staging.pm rakudo-2018.03/lib/CompUnit/Repository/Staging.pm --- rakudo-2018.02.1/lib/CompUnit/Repository/Staging.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/lib/CompUnit/Repository/Staging.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -class CompUnit::Repository::Staging is CompUnit::Repository::Installation { - has Str $.name; - - submethod BUILD(Str :$!name --> Nil) { - CompUnit::RepositoryRegistry.register-name($!name, self); - } - - method short-id() { 'staging' } - - method name(--> Str) { - $!name - } - method path-spec(CompUnit::Repository::Staging:D:) { - self.^name ~ '#name(' ~ $!name ~ ')#' ~ $.prefix.absolute; - } - method source-file(Str $name --> IO::Path) { - my $file = self.prefix.add($name); - $file.e ?? $file !! self.next-repo.source-file($name) - } -} - -# vim: ft=perl6 diff -Nru rakudo-2018.02.1/lib/CompUnit/Repository/Staging.pm6 rakudo-2018.03/lib/CompUnit/Repository/Staging.pm6 --- rakudo-2018.02.1/lib/CompUnit/Repository/Staging.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/lib/CompUnit/Repository/Staging.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,22 @@ +class CompUnit::Repository::Staging is CompUnit::Repository::Installation { + has Str $.name; + + submethod BUILD(Str :$!name --> Nil) { + CompUnit::RepositoryRegistry.register-name($!name, self); + } + + method short-id() { 'staging' } + + method name(--> Str) { + $!name + } + method path-spec(CompUnit::Repository::Staging:D:) { + self.^name ~ '#name(' ~ $!name ~ ')#' ~ $.prefix.absolute; + } + method source-file(Str $name --> IO::Path) { + my $file = self.prefix.add($name); + $file.e ?? $file !! self.next-repo.source-file($name) + } +} + +# vim: ft=perl6 diff -Nru rakudo-2018.02.1/lib/NativeCall.pm6 rakudo-2018.03/lib/NativeCall.pm6 --- rakudo-2018.02.1/lib/NativeCall.pm6 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/lib/NativeCall.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -260,6 +260,7 @@ # native call. our role Native[Routine $r, $libname where Str|Callable|List|IO::Path|Distribution::Resource] { has int $!setup; + has int $!precomp-setup; has native_callsite $!call is box_target; has Mu $!rettype; has $!cpp-name-mangler; @@ -272,8 +273,8 @@ method !setup() { $setup-lock.protect: { - return if $!setup; - # Make sure that C++ methotds are treated as mangled (unless set otherwise) + return if $!setup || $*W && $*W.is_precompilation_mode && $!precomp-setup; + # Make sure that C++ methods are treated as mangled (unless set otherwise) if self.package.REPR eq 'CPPStruct' and not self.does(NativeCallMangled) { self does NativeCallMangled[True]; } @@ -294,7 +295,7 @@ return_hash_for($r.signature, $r, :$!entry-point)); $!rettype := nqp::decont(map_return_type($r.returns)) unless $!rettype; $!arity = $r.signature.arity; - $!setup = $jitted ?? 2 !! 1; + ($*W && $*W.is_precompilation_mode ?? $!precomp-setup !! $!setup) = $jitted ?? 2 !! 1; $!any-optionals = self!any-optionals; @@ -494,11 +495,11 @@ $block } - my $perl6comp := nqp::getcomp("perl6"); - my @stages = $perl6comp.stages; - Nil until @stages.shift eq 'optimize'; - method !compile-function-body(Mu $block) { + my $perl6comp := nqp::getcomp("perl6"); + my @stages = $perl6comp.stages; + Nil until @stages.shift eq 'optimize'; + my $result := $block; $result := $perl6comp.^can($_) ?? $perl6comp."$_"($result) diff -Nru rakudo-2018.02.1/lib/Pod/To/Text.pm6 rakudo-2018.03/lib/Pod/To/Text.pm6 --- rakudo-2018.02.1/lib/Pod/To/Text.pm6 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/lib/Pod/To/Text.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -74,7 +74,7 @@ } for @rows -> $row { # Gutter of two spaces between columns - $ret ~= join ' ', + $ret ~= ' ' ~ join ' ', (@maxes Z=> @$row).map: { .value.fmt("%-{.key}s") }; $ret ~= "\n"; } diff -Nru rakudo-2018.02.1/lib/Test.pm6 rakudo-2018.03/lib/Test.pm6 --- rakudo-2018.02.1/lib/Test.pm6 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/lib/Test.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -483,47 +483,25 @@ } multi sub like( - $got, Regex $expected, - $desc = "text matches '$expected.perl()'" + Str() $got, Regex:D $expected, + $desc = "text matches $expected.perl()" ) is export { $time_after = nqp::time_n; - $got.defined; # Hack to deal with Failures - my $ok; - if $got ~~ Str:D { - my $test = $got ~~ $expected; - $ok = proclaim($test, $desc); - if !$test { - _diag " expected: '$expected.perl()'\n" - ~ " got: '$got'"; - } - } else { - $ok = proclaim(False, $desc); - _diag " expected a Str that matches '$expected.perl()'\n" - ~ " got: '$got.perl()'"; - } + my $ok := proclaim $got ~~ $expected, $desc + or _diag "expected a match with: $expected.perl()\n" + ~ " got: $got.perl()"; $time_before = nqp::time_n; $ok or ($die_on_fail and die-on-fail) or $ok; } multi sub unlike( - $got, Regex $expected, - $desc = "text does not match '$expected.perl()'" + Str() $got, Regex:D $expected, + $desc = "text does not match $expected.perl()" ) is export { $time_after = nqp::time_n; - $got.defined; # Hack to deal with Failures - my $ok; - if $got ~~ Str:D { - my $test = !($got ~~ $expected); - $ok = proclaim($test, $desc); - if !$test { - _diag " expected: '$expected.perl()'\n" - ~ " got: '$got'"; - } - } else { - $ok = proclaim(False, $desc); - _diag " expected: a Str that matches '$expected.perl()'\n" - ~ " got: '$got.perl()'"; - } + my $ok := proclaim !($got ~~ $expected), $desc + or _diag "expected no match with: $expected.perl()\n" + ~ " got: $got.perl()"; $time_before = nqp::time_n; $ok or ($die_on_fail and die-on-fail) or $ok; } diff -Nru rakudo-2018.02.1/MANIFEST rakudo-2018.03/MANIFEST --- rakudo-2018.02.1/MANIFEST 2018-02-23 05:52:48.000000000 +0000 +++ rakudo-2018.03/MANIFEST 2018-03-19 12:09:01.000000000 +0000 @@ -119,9 +119,11 @@ docs/announce/2018.01.md docs/announce/2018.02.1.md docs/announce/2018.02.md +docs/announce/2018.03.md docs/architecture.html docs/architecture.svg docs/archive/2017-IO-Grant--Action-Plan.md +docs/archive/2018-03-04--Polishing-Rationals.md docs/archive/constants-type-constraints-proposal-2018-02-10.md docs/ChangeLog docs/compiler_overview.pod @@ -146,7 +148,7 @@ gen/jvm/.gitignore gen/moar/.gitignore INSTALL.txt -lib/CompUnit/Repository/Staging.pm +lib/CompUnit/Repository/Staging.pm6 lib/experimental.pm6 lib/NativeCall/Compiler/GNU.pm6 lib/NativeCall/Compiler/MSVC.pm6 @@ -160,223 +162,223 @@ LICENSE MANIFEST README.md -src/core/allomorphs.pm -src/core/Any-iterable-methods.pm -src/core/Any.pm -src/core/Argfiles.pm -src/core/array_operators.pm -src/core/Array.pm -src/core/array_slice.pm -src/core/Associative.pm -src/core/AST.pm -src/core/asyncops.pm -src/core/atomicops.pm -src/core/Attribute.pm -src/core/Awaitable.pm -src/core/Awaiter.pm -src/core/Backtrace.pm -src/core/Baggy.pm -src/core/BagHash.pm -src/core/Bag.pm -src/core/Block.pm -src/core/Bool.pm -src/core/Buf.pm -src/core/Callable.pm -src/core/CallFrame.pm -src/core/Cancellation.pm -src/core/Capture.pm -src/core/Channel.pm -src/core/Code.pm -src/core/Collation.pm -src/core/Compiler.pm -src/core/Complex.pm -src/core/CompUnit/DependencySpecification.pm -src/core/CompUnit/Handle.pm -src/core/CompUnit/Loader.pm -src/core/CompUnit.pm -src/core/CompUnit/PrecompilationRepository.pm -src/core/CompUnit/PrecompilationStore/File.pm -src/core/CompUnit/PrecompilationStore.pm -src/core/CompUnit/PrecompilationUnit.pm -src/core/CompUnit/Repository/AbsolutePath.pm -src/core/CompUnit/Repository/FileSystem.pm -src/core/CompUnit/Repository/Installable.pm -src/core/CompUnit/Repository/Installation.pm -src/core/CompUnit/Repository/Locally.pm -src/core/CompUnit/Repository/NQP.pm -src/core/CompUnit/Repository/Perl5.pm -src/core/CompUnit/Repository.pm -src/core/CompUnit/RepositoryRegistry.pm -src/core/CompUnit/Repository/Spec.pm -src/core/CompUnit/Repository/Unknown.pm -src/core/control.pm -src/core/Cool.pm -src/core/core_epilogue.pm -src/core/core_prologue.pm -src/core/CurrentThreadScheduler.pm -src/core/Cursor.pm -src/core/Dateish.pm -src/core/Date.pm -src/core/DateTime.pm -src/core.d/await.pm -src/core.d/core_prologue.pm -src/core/Deprecations.pm -src/core/Distribution.pm -src/core/Distro.pm -src/core/Duration.pm -src/core/Encoding/Builtin.pm -src/core/Encoding/Decoder/Builtin.pm -src/core/Encoding/Decoder.pm -src/core/Encoding/Encoder/Builtin.pm -src/core/Encoding/Encoder.pm -src/core/Encoding/Encoder/TranslateNewlineWrapper.pm -src/core/Encoding.pm -src/core/Encoding/Registry.pm -src/core/Enumeration.pm -src/core/Env.pm -src/core/Exception.pm -src/core/EXPORTHOW.pm -src/core/Failure.pm -src/core/ForeignCode.pm -src/core/Grammar.pm -src/core/Hash.pm -src/core/hash_slice.pm -src/core/HyperConfiguration.pm -src/core/HyperSeq.pm -src/core/Instant.pm -src/core/Int.pm -src/core/IO/ArgFiles.pm -src/core/IO/CatHandle.pm -src/core/IO/Handle.pm -src/core/IO/Notification.pm -src/core/io_operators.pm -src/core/IO/Path.pm -src/core/IO/Pipe.pm -src/core/IO.pm -src/core/IO/Socket/Async.pm -src/core/IO/Socket/INET.pm -src/core/IO/Socket.pm -src/core/IO/Spec/Cygwin.pm -src/core/IO/Special.pm -src/core/IO/Spec.pm -src/core/IO/Spec/QNX.pm -src/core/IO/Spec/Unix.pm -src/core/IO/Spec/Win32.pm -src/core/Iterable.pm -src/core/IterationBuffer.pm -src/core/Iterator.pm -src/core/JSON/Pretty.pm -src/core/Junction.pm -src/core/JVM/IOAsyncFile.pm -src/core/JVM/KeyReducer.pm -src/core/Kernel.pm -src/core/Label.pm -src/core/List.pm -src/core/Lock/Async.pm -src/core/Lock.pm -src/core/Macro.pm -src/core/Main.pm -src/core/Map.pm -src/core/Match.pm -src/core/Metamodel/Primitives.pm -src/core/metaops.pm -src/core/Method.pm -src/core/MixHash.pm -src/core/Mix.pm -src/core/Mixy.pm -src/core/multidim_slice.pm -src/core/Mu.pm -src/core/native_array.pm -src/core/natives.pm -src/core/Nil.pm -src/core/Numeric.pm -src/core/Num.pm -src/core/ObjAt.pm -src/core/operators.pm -src/core/Order.pm -src/core/OS.pm -src/core/Pair.pm -src/core/Parameter.pm -src/core/Perl.pm -src/core/Pod.pm -src/core/Positional.pm -src/core/precedence.pm -src/core/Proc/Async.pm -src/core/Process.pm -src/core/Proc.pm -src/core/Promise.pm -src/core/PseudoStash.pm -src/core/QuantHash.pm -src/core/RaceSeq.pm -src/core/Rakudo/Internals/HyperIteratorBatcher.pm -src/core/Rakudo/Internals/HyperPipeline.pm -src/core/Rakudo/Internals/HyperRaceSharedImpl.pm -src/core/Rakudo/Internals/HyperToIterator.pm -src/core/Rakudo/Internals/HyperWorkBatch.pm -src/core/Rakudo/Internals/HyperWorkStage.pm -src/core/Rakudo/Internals/JSON.pm -src/core/Rakudo/Internals.pm -src/core/Rakudo/Internals/RaceToIterator.pm -src/core/Rakudo/Iterator.pm -src/core/Rakudo/Metaops.pm -src/core/Rakudo/QuantHash.pm -src/core/Rakudo/Sorting.pm -src/core/Range.pm -src/core/Rational.pm -src/core/Rat.pm -src/core/Real.pm -src/core/Regex.pm -src/core/REPL.pm -src/core/Routine.pm -src/core/Scalar.pm -src/core/Scheduler.pm -src/core/Semaphore.pm -src/core/Seq.pm -src/core/Sequence.pm -src/core/set_addition.pm -src/core/set_difference.pm -src/core/set_elem.pm -src/core/SetHash.pm -src/core/set_intersection.pm -src/core/set_multiply.pm -src/core/set_operators.pm -src/core/Set.pm -src/core/set_precedes.pm -src/core/set_proper_subset.pm -src/core/set_subset.pm -src/core/set_symmetric_difference.pm -src/core/Setty.pm -src/core/set_union.pm -src/core/Shaped1Array.pm -src/core/Shaped2Array.pm -src/core/Shaped3Array.pm -src/core/ShapedArray.pm -src/core/ShapedNArray.pm -src/core/signals.pm -src/core/Signature.pm -src/core/Slang.pm -src/core/SLICE.pm -src/core/Slip.pm -src/core/SlippyIterator.pm -src/core/Stash.pm -src/core/StrDistance.pm -src/core/Stringy.pm -src/core/Str.pm -src/core/stubs.pm -src/core/Submethod.pm -src/core/Sub.pm -src/core/Supply.pm -src/core/Systemic.pm -src/core/Thread.pm -src/core/ThreadPoolScheduler.pm -src/core/traits.pm -src/core/TypedArray.pm -src/core/Uni.pm -src/core/Variable.pm -src/core/Version.pm -src/core/VM.pm -src/core/WhateverCode.pm -src/core/Whatever.pm +src/core/allomorphs.pm6 +src/core/Any-iterable-methods.pm6 +src/core/Any.pm6 +src/core/Argfiles.pm6 +src/core/array_operators.pm6 +src/core/Array.pm6 +src/core/array_slice.pm6 +src/core/Associative.pm6 +src/core/AST.pm6 +src/core/asyncops.pm6 +src/core/atomicops.pm6 +src/core/Attribute.pm6 +src/core/Awaitable.pm6 +src/core/Awaiter.pm6 +src/core/Backtrace.pm6 +src/core/Baggy.pm6 +src/core/BagHash.pm6 +src/core/Bag.pm6 +src/core/Block.pm6 +src/core/Bool.pm6 +src/core/Buf.pm6 +src/core/Callable.pm6 +src/core/CallFrame.pm6 +src/core/Cancellation.pm6 +src/core/Capture.pm6 +src/core/Channel.pm6 +src/core/Code.pm6 +src/core/Collation.pm6 +src/core/Compiler.pm6 +src/core/Complex.pm6 +src/core/CompUnit/DependencySpecification.pm6 +src/core/CompUnit/Handle.pm6 +src/core/CompUnit/Loader.pm6 +src/core/CompUnit.pm6 +src/core/CompUnit/PrecompilationRepository.pm6 +src/core/CompUnit/PrecompilationStore/File.pm6 +src/core/CompUnit/PrecompilationStore.pm6 +src/core/CompUnit/PrecompilationUnit.pm6 +src/core/CompUnit/Repository/AbsolutePath.pm6 +src/core/CompUnit/Repository/FileSystem.pm6 +src/core/CompUnit/Repository/Installable.pm6 +src/core/CompUnit/Repository/Installation.pm6 +src/core/CompUnit/Repository/Locally.pm6 +src/core/CompUnit/Repository/NQP.pm6 +src/core/CompUnit/Repository/Perl5.pm6 +src/core/CompUnit/Repository.pm6 +src/core/CompUnit/RepositoryRegistry.pm6 +src/core/CompUnit/Repository/Spec.pm6 +src/core/CompUnit/Repository/Unknown.pm6 +src/core/control.pm6 +src/core/Cool.pm6 +src/core/core_epilogue.pm6 +src/core/core_prologue.pm6 +src/core/CurrentThreadScheduler.pm6 +src/core/Cursor.pm6 +src/core/Dateish.pm6 +src/core/Date.pm6 +src/core/DateTime.pm6 +src/core.d/await.pm6 +src/core.d/core_prologue.pm6 +src/core/Deprecations.pm6 +src/core/Distribution.pm6 +src/core/Distro.pm6 +src/core/Duration.pm6 +src/core/Encoding/Builtin.pm6 +src/core/Encoding/Decoder/Builtin.pm6 +src/core/Encoding/Decoder.pm6 +src/core/Encoding/Encoder/Builtin.pm6 +src/core/Encoding/Encoder.pm6 +src/core/Encoding/Encoder/TranslateNewlineWrapper.pm6 +src/core/Encoding.pm6 +src/core/Encoding/Registry.pm6 +src/core/Enumeration.pm6 +src/core/Env.pm6 +src/core/Exception.pm6 +src/core/EXPORTHOW.pm6 +src/core/Failure.pm6 +src/core/ForeignCode.pm6 +src/core/Grammar.pm6 +src/core/Hash.pm6 +src/core/hash_slice.pm6 +src/core/HyperConfiguration.pm6 +src/core/HyperSeq.pm6 +src/core/Instant.pm6 +src/core/Int.pm6 +src/core/IO/ArgFiles.pm6 +src/core/IO/CatHandle.pm6 +src/core/IO/Handle.pm6 +src/core/IO/Notification.pm6 +src/core/io_operators.pm6 +src/core/IO/Path.pm6 +src/core/IO/Pipe.pm6 +src/core/IO.pm6 +src/core/IO/Socket/Async.pm6 +src/core/IO/Socket/INET.pm6 +src/core/IO/Socket.pm6 +src/core/IO/Spec/Cygwin.pm6 +src/core/IO/Special.pm6 +src/core/IO/Spec.pm6 +src/core/IO/Spec/QNX.pm6 +src/core/IO/Spec/Unix.pm6 +src/core/IO/Spec/Win32.pm6 +src/core/Iterable.pm6 +src/core/IterationBuffer.pm6 +src/core/Iterator.pm6 +src/core/JSON/Pretty.pm6 +src/core/Junction.pm6 +src/core/JVM/IOAsyncFile.pm6 +src/core/JVM/KeyReducer.pm6 +src/core/Kernel.pm6 +src/core/Label.pm6 +src/core/List.pm6 +src/core/Lock/Async.pm6 +src/core/Lock.pm6 +src/core/Macro.pm6 +src/core/Main.pm6 +src/core/Map.pm6 +src/core/Match.pm6 +src/core/Metamodel/Primitives.pm6 +src/core/metaops.pm6 +src/core/Method.pm6 +src/core/MixHash.pm6 +src/core/Mix.pm6 +src/core/Mixy.pm6 +src/core/multidim_slice.pm6 +src/core/Mu.pm6 +src/core/native_array.pm6 +src/core/natives.pm6 +src/core/Nil.pm6 +src/core/Numeric.pm6 +src/core/Num.pm6 +src/core/ObjAt.pm6 +src/core/operators.pm6 +src/core/Order.pm6 +src/core/OS.pm6 +src/core/Pair.pm6 +src/core/Parameter.pm6 +src/core/Perl.pm6 +src/core/Pod.pm6 +src/core/Positional.pm6 +src/core/precedence.pm6 +src/core/Proc/Async.pm6 +src/core/Process.pm6 +src/core/Proc.pm6 +src/core/Promise.pm6 +src/core/PseudoStash.pm6 +src/core/QuantHash.pm6 +src/core/RaceSeq.pm6 +src/core/Rakudo/Internals/HyperIteratorBatcher.pm6 +src/core/Rakudo/Internals/HyperPipeline.pm6 +src/core/Rakudo/Internals/HyperRaceSharedImpl.pm6 +src/core/Rakudo/Internals/HyperToIterator.pm6 +src/core/Rakudo/Internals/HyperWorkBatch.pm6 +src/core/Rakudo/Internals/HyperWorkStage.pm6 +src/core/Rakudo/Internals/JSON.pm6 +src/core/Rakudo/Internals.pm6 +src/core/Rakudo/Internals/RaceToIterator.pm6 +src/core/Rakudo/Iterator.pm6 +src/core/Rakudo/Metaops.pm6 +src/core/Rakudo/QuantHash.pm6 +src/core/Rakudo/Sorting.pm6 +src/core/Range.pm6 +src/core/Rational.pm6 +src/core/Rat.pm6 +src/core/Real.pm6 +src/core/Regex.pm6 +src/core/REPL.pm6 +src/core/Routine.pm6 +src/core/Scalar.pm6 +src/core/Scheduler.pm6 +src/core/Semaphore.pm6 +src/core/Seq.pm6 +src/core/Sequence.pm6 +src/core/set_addition.pm6 +src/core/set_difference.pm6 +src/core/set_elem.pm6 +src/core/SetHash.pm6 +src/core/set_intersection.pm6 +src/core/set_multiply.pm6 +src/core/set_operators.pm6 +src/core/Set.pm6 +src/core/set_precedes.pm6 +src/core/set_proper_subset.pm6 +src/core/set_subset.pm6 +src/core/set_symmetric_difference.pm6 +src/core/Setty.pm6 +src/core/set_union.pm6 +src/core/Shaped1Array.pm6 +src/core/Shaped2Array.pm6 +src/core/Shaped3Array.pm6 +src/core/ShapedArray.pm6 +src/core/ShapedNArray.pm6 +src/core/signals.pm6 +src/core/Signature.pm6 +src/core/Slang.pm6 +src/core/SLICE.pm6 +src/core/Slip.pm6 +src/core/SlippyIterator.pm6 +src/core/Stash.pm6 +src/core/StrDistance.pm6 +src/core/Stringy.pm6 +src/core/Str.pm6 +src/core/stubs.pm6 +src/core/Submethod.pm6 +src/core/Sub.pm6 +src/core/Supply.pm6 +src/core/Systemic.pm6 +src/core/Thread.pm6 +src/core/ThreadPoolScheduler.pm6 +src/core/traits.pm6 +src/core/TypedArray.pm6 +src/core/Uni.pm6 +src/core/Variable.pm6 +src/core/Version.pm6 +src/core/VM.pm6 +src/core/WhateverCode.pm6 +src/core/Whatever.pm6 src/main.nqp src/Perl6/Actions.nqp src/Perl6/Compiler.nqp @@ -437,8 +439,8 @@ src/Perl6/Pod.nqp src/Perl6/World.nqp src/RESTRICTED.setting -src/vm/jvm/CompUnit/Repository/Java.pm -src/vm/jvm/CompUnit/Repository/JavaRuntime.pm +src/vm/jvm/CompUnit/Repository/Java.pm6 +src/vm/jvm/CompUnit/Repository/JavaRuntime.pm6 src/vm/jvm/ModuleLoaderVMConfig.nqp src/vm/jvm/Perl6/JavaModuleLoader.nqp src/vm/jvm/Perl6/Metamodel/JavaHOW.nqp @@ -491,12 +493,15 @@ t/02-rakudo/09-thread-id-after-await.t t/02-rakudo/10-nqp-ops.t t/02-rakudo/11-deprecated.t +t/02-rakudo/dd.t t/02-rakudo/dump.t t/02-rakudo/repl.t t/02-rakudo/test-packages/CustomOps.pm6 t/02-rakudo/v6.d-tests/01-deprecations.t t/03-jvm/01-interop.t t/03-jvm/Foo.java +t/04-nativecall/00-misc.c +t/04-nativecall/00-misc.t t/04-nativecall/01-argless.c t/04-nativecall/01-argless.t t/04-nativecall/02-simple-args.c @@ -541,7 +546,7 @@ t/04-nativecall/21-callback-other-thread.t t/04-nativecall/22-method.c t/04-nativecall/22-method.t -t/04-nativecall/CompileTestLib.pm +t/04-nativecall/CompileTestLib.pm6 t/05-messages/01-errors.t t/05-messages/02-errors.t t/05-messages/03-errors.t @@ -596,9 +601,9 @@ tools/build/nqp-jvm-rr.pl tools/build/NQP_REVISION tools/build/upgrade-repository.pl -tools/contributors.pl6 -tools/create-release-announcement.pl6 -tools/CREDITS.pl6 +tools/contributors.p6 +tools/create-release-announcement.p6 +tools/CREDITS.p6 tools/install-dist.pl tools/lib/NQP/Configure.pm tools/perl6-limited.pl diff -Nru rakudo-2018.02.1/README.md rakudo-2018.03/README.md --- rakudo-2018.02.1/README.md 2018-02-23 05:08:43.000000000 +0000 +++ rakudo-2018.03/README.md 2018-03-19 11:27:21.000000000 +0000 @@ -19,6 +19,10 @@ Recent changes and feature additions are documented in the `docs/ChangeLog` text file. +To receive important notifications from the core developer team, please +subscribe to [the p6lert service](https://alerts.perl6.org) using the RSS feed, +twitter, or [the p6lert commandline script](https://github.com/zoffixznet/perl6-p6lert). + ## Building and Installing Rakudo [![Build Status](https://travis-ci.org/rakudo/rakudo.svg?branch=master)](https://travis-ci.org/rakudo/rakudo) [![Build status](https://ci.appveyor.com/api/projects/status/github/rakudo/rakudo?svg=true)](https://ci.appveyor.com/project/rakudo/rakudo/branch/master) @@ -122,8 +126,8 @@ are also welcome on the #perl6 channel; the Rakudo and Perl 6 development teams tend to hang out there and are generally glad to help. You can follow [@perl6org](https://twitter.com/perl6org) -and [@rakudoperl](https://twitter.com/rakudoperl) on Twitter, and there's -a Perl 6 news aggregator at [Planet Perl 6](http://pl6anet.org/). +and on Twitter, there's a Perl 6 news aggregator at +[Planet Perl 6](http://pl6anet.org/). Questions about NQP can also be posted to the #perl6 IRC channel. For questions about MoarVM, you can join #moarvm on freenode. diff -Nru rakudo-2018.02.1/src/core/allomorphs.pm rakudo-2018.03/src/core/allomorphs.pm --- rakudo-2018.02.1/src/core/allomorphs.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/allomorphs.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,571 +0,0 @@ -# the uses of add_I in this class are a trick to make bigints work right -my class IntStr is Int is Str { - method new(Int:D $i, Str:D $s) { - my \SELF = nqp::add_I($i, 0, self); - nqp::bindattr_s(SELF, Str, '$!value', $s); - SELF; - } - multi method ACCEPTS(IntStr:D: Any:D \a) { - nqp::if( - nqp::istype(a, Numeric), - self.Int.ACCEPTS(a), - nqp::if( - nqp::istype(a, Str), - self.Str.ACCEPTS(a), - self.Str.ACCEPTS(a) && self.Int.ACCEPTS(a))) - } - multi method Numeric(IntStr:D:) { self.Int } - multi method Numeric(IntStr:U:) { - self.Mu::Numeric; # issue warning; - 0 - } - multi method Real(IntStr:D:) { self.Int } - multi method Real(IntStr:U:) { - self.Mu::Real; # issue warning; - 0 - } - method Int(IntStr:D:) { nqp::add_I(self, 0, Int) } - multi method Str(IntStr:D:) { nqp::getattr_s(self, Str, '$!value') } - - multi method perl(IntStr:D:) { self.^name ~ '.new(' ~ self.Int.perl ~ ', ' ~ self.Str.perl ~ ')' } -} - -my class NumStr is Num is Str { - method new(Num $n, Str $s) { - my \SELF = nqp::create(self); - nqp::bindattr_n(SELF, Num, '$!value', $n); - nqp::bindattr_s(SELF, Str, '$!value', $s); - SELF; - } - multi method ACCEPTS(NumStr:D: Any:D \a) { - nqp::if( - nqp::istype(a, Numeric), - self.Num.ACCEPTS(a), - nqp::if( - nqp::istype(a, Str), - self.Str.ACCEPTS(a), - self.Str.ACCEPTS(a) && self.Num.ACCEPTS(a))) - } - multi method Numeric(NumStr:D:) { self.Num } - multi method Numeric(NumStr:U:) { - self.Mu::Numeric; # issue warning; - 0e0 - } - multi method Real(NumStr:D:) { self.Num } - multi method Real(NumStr:U:) { - self.Mu::Real; # issue warning; - 0e0 - } - method Num(NumStr:D:) { nqp::getattr_n(self, Num, '$!value') } - multi method Str(NumStr:D:) { nqp::getattr_s(self, Str, '$!value') } - - multi method perl(NumStr:D:) { self.^name ~ '.new(' ~ self.Num.perl ~ ', ' ~ self.Str.perl ~ ')' } -} - -my class RatStr is Rat is Str { - method new(Rat $r, Str $s) { - my \SELF = nqp::create(self); - nqp::bindattr(SELF, Rat, '$!numerator', $r.numerator); - nqp::bindattr(SELF, Rat, '$!denominator', $r.denominator); - nqp::bindattr_s(SELF, Str, '$!value', $s); - SELF; - } - multi method ACCEPTS(RatStr:D: Any:D \a) { - nqp::if( - nqp::istype(a, Numeric), - self.Rat.ACCEPTS(a), - nqp::if( - nqp::istype(a, Str), - self.Str.ACCEPTS(a), - self.Str.ACCEPTS(a) && self.Rat.ACCEPTS(a))) - } - method succ(RatStr:D: --> Rat:D) { - nqp::p6bindattrinvres( - nqp::p6bindattrinvres(nqp::create(Rat), Rat, '$!numerator', - nqp::add_I( - nqp::getattr(self, Rat, '$!numerator'), - nqp::getattr(self, Rat, '$!denominator'), Int)), - Rat, '$!denominator', nqp::getattr(self, Rat, '$!denominator')) - } - method pred(RatStr:D: --> Rat:D) { - nqp::p6bindattrinvres( - nqp::p6bindattrinvres(nqp::create(Rat), Rat, '$!numerator', - nqp::sub_I( - nqp::getattr(self, Rat, '$!numerator'), - nqp::getattr(self, Rat, '$!denominator'), Int)), - Rat, '$!denominator', nqp::getattr(self, Rat, '$!denominator')) - } - method Capture(RatStr:D:) { self.Mu::Capture } - multi method Numeric(RatStr:D:) { self.Rat } - multi method Numeric(RatStr:U:) { - self.Mu::Numeric; # issue warning; - 0.0 - } - multi method Real(RatStr:D:) { self.Rat } - multi method Real(RatStr:U:) { - self.Mu::Real; # issue warning; - 0.0 - } - method Rat(RatStr:D:) { Rat.new(nqp::getattr(self, Rat, '$!numerator'), nqp::getattr(self, Rat, '$!denominator')) } - multi method Str(RatStr:D:) { nqp::getattr_s(self, Str, '$!value') } - - multi method perl(RatStr:D:) { self.^name ~ '.new(' ~ self.Rat.perl ~ ', ' ~ self.Str.perl ~ ')' } -} - -my class ComplexStr is Complex is Str { - method new(Complex $c, Str $s) { - my \SELF = nqp::create(self); - nqp::bindattr_n(SELF, Complex, '$!re', $c.re); - nqp::bindattr_n(SELF, Complex, '$!im', $c.im); - nqp::bindattr_s(SELF, Str, '$!value', $s); - SELF; - } - multi method ACCEPTS(ComplexStr:D: Any:D \a) { - nqp::if( - nqp::istype(a, Numeric), - self.Complex.ACCEPTS(a), - nqp::if( - nqp::istype(a, Str), - self.Str.ACCEPTS(a), - self.Str.ACCEPTS(a) && self.Complex.ACCEPTS(a))) - } - method Capture(ComplexStr:D:) { self.Mu::Capture } - multi method Numeric(ComplexStr:D:) { self.Complex } - multi method Numeric(ComplexStr:U:) { - self.Mu::Numeric; # issue warning; - <0+0i> - } - multi method Real(ComplexStr:D:) { self.Complex.Real } - multi method Real(ComplexStr:U:) { - self.Mu::Real; # issue warning; - <0+0i>.Real - } - method Complex(ComplexStr:D:) { Complex.new(nqp::getattr_n(self, Complex, '$!re'), nqp::getattr_n(self, Complex, '$!im')) } - multi method Str(ComplexStr:D:) { nqp::getattr_s(self, Str, '$!value') } - - multi method perl(ComplexStr:D:) { self.^name ~ '.new(' ~ self.Complex.perl ~ ', ' ~ self.Str.perl ~ ')' } -} - -# we define cmp ops for these allomorphic types as numeric first, then Str. If -# you want just one half of the cmp, you'll need to coerce the args -multi sub infix:(IntStr:D $a, IntStr:D $b) { $a.Int cmp $b.Int || $a.Str cmp $b.Str } -multi sub infix:(IntStr:D $a, RatStr:D $b) { $a.Int cmp $b.Rat || $a.Str cmp $b.Str } -multi sub infix:(IntStr:D $a, NumStr:D $b) { $a.Int cmp $b.Num || $a.Str cmp $b.Str } -multi sub infix:(IntStr:D $a, ComplexStr:D $b) { $a.Int cmp $b.Complex || $a.Str cmp $b.Str } - -multi sub infix:(RatStr:D $a, IntStr:D $b) { $a.Rat cmp $b.Int || $a.Str cmp $b.Str } -multi sub infix:(RatStr:D $a, RatStr:D $b) { $a.Rat cmp $b.Rat || $a.Str cmp $b.Str } -multi sub infix:(RatStr:D $a, NumStr:D $b) { $a.Rat cmp $b.Num || $a.Str cmp $b.Str } -multi sub infix:(RatStr:D $a, ComplexStr:D $b) { $a.Rat cmp $b.Complex || $a.Str cmp $b.Str } - -multi sub infix:(NumStr:D $a, IntStr:D $b) { $a.Num cmp $b.Int || $a.Str cmp $b.Str } -multi sub infix:(NumStr:D $a, RatStr:D $b) { $a.Num cmp $b.Rat || $a.Str cmp $b.Str } -multi sub infix:(NumStr:D $a, NumStr:D $b) { $a.Num cmp $b.Num || $a.Str cmp $b.Str } -multi sub infix:(NumStr:D $a, ComplexStr:D $b) { $a.Num cmp $b.Complex || $a.Str cmp $b.Str } - -multi sub infix:(ComplexStr:D $a, IntStr:D $b) { $a.Complex cmp $b.Int || $a.Str cmp $b.Str } -multi sub infix:(ComplexStr:D $a, RatStr:D $b) { $a.Complex cmp $b.Rat || $a.Str cmp $b.Str } -multi sub infix:(ComplexStr:D $a, NumStr:D $b) { $a.Complex cmp $b.Num || $a.Str cmp $b.Str } -multi sub infix:(ComplexStr:D $a, ComplexStr:D $b) { $a.Complex cmp $b.Complex || $a.Str cmp $b.Str } - - -multi sub infix:(IntStr:D $a, IntStr:D $b) { $a.Int eqv $b.Int && $a.Str eqv $b.Str } -multi sub infix:(IntStr:D $a, RatStr:D $b --> False) {} -multi sub infix:(IntStr:D $a, NumStr:D $b --> False) {} -multi sub infix:(IntStr:D $a, ComplexStr:D $b --> False) {} - -multi sub infix:(RatStr:D $a, IntStr:D $b --> False) {} -multi sub infix:(RatStr:D $a, RatStr:D $b) { $a.Rat eqv $b.Rat && $a.Str eqv $b.Str } -multi sub infix:(RatStr:D $a, NumStr:D $b --> False) {} -multi sub infix:(RatStr:D $a, ComplexStr:D $b --> False) {} - -multi sub infix:(NumStr:D $a, IntStr:D $b --> False) {} -multi sub infix:(NumStr:D $a, RatStr:D $b --> False) {} -multi sub infix:(NumStr:D $a, NumStr:D $b) { $a.Num eqv $b.Num && $a.Str eqv $b.Str } -multi sub infix:(NumStr:D $a, ComplexStr:D $b --> False) {} - -multi sub infix:(ComplexStr:D $a, IntStr:D $b --> False) {} -multi sub infix:(ComplexStr:D $a, RatStr:D $b --> False) {} -multi sub infix:(ComplexStr:D $a, NumStr:D $b --> False) {} -multi sub infix:(ComplexStr:D $a, ComplexStr:D $b) { $a.Complex eqv $b.Complex && $a.Str eqv $b.Str } - -multi sub infix:<===>(IntStr:D $a, IntStr:D $b) { - $a.Int === $b.Int && $a.Str === $b.Str -} -multi sub infix:<===>(RatStr:D $a, RatStr:D $b) { - $a.Rat === $b.Rat && $a.Str === $b.Str -} -multi sub infix:<===>(NumStr:D $a, NumStr:D $b) { - $a.Num === $b.Num && $a.Str === $b.Str -} -multi sub infix:<===>(ComplexStr:D $a, ComplexStr:D $b) { - $a.Complex === $b.Complex && $a.Str === $b.Str -} - -multi sub val(*@maybevals) { - @maybevals.list.map({ val($_) }).eager; -} - -multi sub val(Mu) { - warn "Value of type Mu uselessly passed to val()"; - Mu -} - -# if Slip, preserve slipness -multi sub val(List:D $maybevals) { - nqp::stmts( - (my $output := val(|$maybevals)), - nqp::if( - nqp::istype($maybevals, Slip), - $output.Slip, - $output - ) - ) -} - -multi sub val(Pair:D \ww-thing) is raw { - # this is a Pair object possible in «» constructs; just pass it through. We - # capture this specially from the below sub to avoid emitting a warning - # whenever an affected «» construct is being processed. - - ww-thing -} - -multi sub val(\one-thing) { - warn "Value of type {one-thing.WHAT.perl} uselessly passed to val()"; - one-thing; -} - -multi sub val(Str:D $MAYBEVAL, :$val-or-fail) { - # TODO: - # * Additional numeric styles: - # + fractions in [] radix notation: :100[10,'.',53] - # * Performance tuning - # * Fix remaining XXXX - - my str $str = nqp::unbox_s($MAYBEVAL); - my int $eos = nqp::chars($str); - return IntStr.new(0,"") unless $eos; # handle "" - - # S02:3276-3277: Ignore leading and trailing whitespace - my int $pos = nqp::findnotcclass(nqp::const::CCLASS_WHITESPACE, - $str, 0, $eos); - my int $end = nqp::sub_i($eos, 1); - - $end = nqp::sub_i($end, 1) - while nqp::isge_i($end, $pos) - && nqp::iscclass(nqp::const::CCLASS_WHITESPACE, $str, $end); - - # Fail all the way out when parse failures occur. Return the original - # string, or a failure if we're Str.Numeric - my &parse_fail := -> \msg { - $val-or-fail - ?? fail X::Str::Numeric.new(:source($MAYBEVAL),:reason(msg),:$pos) - !! return $MAYBEVAL - } - - # Str.Numeric should handle blank string before val() - parse_fail "Empty string not properly caught before val()" if nqp::islt_i($end, $pos); - - # Reset end-of-string after trimming - $eos = nqp::add_i($end, 1); - - # return an appropriate type when we've found a number. Allomorphic unless - # Str.Numeric is calling - my &parse_win := -> \newval { - $val-or-fail - ?? return newval - !! nqp::istype(newval, Num) - ?? return NumStr.new(newval, $MAYBEVAL) - !! nqp::istype(newval, Rat) - ?? return RatStr.new(newval, $MAYBEVAL) - !! nqp::istype(newval, Complex) - ?? return ComplexStr.new(newval, $MAYBEVAL) - !! nqp::istype(newval, Int) - ?? return IntStr.new(newval, $MAYBEVAL) - !! die "Unknown type {newval.^name} found in val() processing" - } - - my sub parse-simple-number() { - # Handle NaN here, to make later parsing simpler - if nqp::eqat($str,'NaN',$pos) { - $pos = nqp::add_i($pos, 3); - return nqp::p6box_n(nqp::nan()); - } - - # Handle any leading +/-/− sign - my int $ch = nqp::ord($str, $pos); - my int $neg = nqp::iseq_i($ch, 45) || nqp::iseq_i($ch, 8722); # '-', '−' - if $neg || nqp::iseq_i($ch, 43) { # '-', '−', '+' - $pos = nqp::add_i($pos, 1); - $ch = nqp::islt_i($pos, $eos) && nqp::ord($str, $pos); - } - - # nqp::radix_I parse results, and helper values - my Mu $parse; - my str $prefix; - my int $radix; - my int $p; - - my sub parse-int-frac-exp() { - # Integer part, if any - my Int $int := 0; - if nqp::isne_i($ch, 46) { # '.' - parse_fail "Cannot convert radix of $radix (max 36)" - if nqp::isgt_i($radix, 36); - $parse := nqp::radix_I($radix, $str, $pos, $neg, Int); - $p = nqp::atpos($parse, 2); - parse_fail "base-$radix number must begin with valid digits or '.'" - if nqp::iseq_i($p, -1); - $pos = $p; - - $int := nqp::atpos($parse, 0); - nqp::isge_i($pos, $eos) - ?? return $int - !! ($ch = nqp::ord($str, $pos)); - } - - # Fraction, if any - my Int $frac := 0; - my Int $base := 0; - if nqp::iseq_i($ch, 46) { # '.' - $pos = nqp::add_i($pos, 1); - $parse := nqp::radix_I($radix, $str, $pos, - nqp::add_i($neg, 4), Int); - $p = nqp::atpos($parse, 2); - parse_fail 'radix point must be followed by one or more valid digits' - if nqp::iseq_i($p, -1); - $pos = $p; - - $frac := nqp::atpos($parse, 0); - $base := nqp::atpos($parse, 1); - $ch = nqp::islt_i($pos, $eos) && nqp::ord($str, $pos); - } - - # Exponent, if 'E' or 'e' are present (forces return type Num) - if nqp::iseq_i($ch, 69) || nqp::iseq_i($ch, 101) { # 'E', 'e' - parse_fail "'E' or 'e' style exponent only allowed on decimal (base-10) numbers, not base-$radix" - unless nqp::iseq_i($radix, 10); - - $pos = nqp::add_i($pos, 1); - # handle the sign - # XXX TODO: teach radix_I to handle '−' (U+2212) minus? - my int $ch = nqp::islt_i($pos, $eos) && nqp::ord($str, $pos); - my int $neg-e = nqp::if( - nqp::iseq_i($ch, 43), # '+' - nqp::stmts(($pos = nqp::add_i($pos, 1)), 0), - nqp::if( # '-', '−' - nqp::iseq_i($ch, 45) || nqp::iseq_i($ch, 8722), - nqp::stmts(($pos = nqp::add_i($pos, 1)), 1), - 0, - ) - ); - - $parse := nqp::radix_I(10, $str, $pos, $neg-e, Int); - $p = nqp::atpos($parse, 2); - parse_fail "'E' or 'e' must be followed by decimal (base-10) integer" - if nqp::iseq_i($p, -1); - $pos = $p; - - return nqp::p6box_n(nqp::mul_n( - $frac ?? nqp::add_n( $int.Num, nqp::div_n($frac.Num, $base.Num) ) - !! $int.Num, - nqp::pow_n(10e0, nqp::atpos($parse, 0).Num) - )) # if we have a zero, handle the sign correctly - || nqp::if(nqp::iseq_i($neg, 1), -0e0, 0e0); - } - - # Multiplier with exponent, if single '*' is present - # (but skip if current token is '**', as otherwise we - # get recursive multiplier parsing stupidity) - if nqp::iseq_i($ch, 42) - && nqp::isne_s(substr($str, $pos, 2), '**') { # '*' - $pos = nqp::add_i($pos, 1); - my $mult_base := parse-simple-number(); - - parse_fail "'*' multiplier base must be an integer" - unless nqp::istype($mult_base, Int); - parse_fail "'*' multiplier base must be followed by '**' and exponent" - unless nqp::eqat($str,'**',$pos); - - $pos = nqp::add_i($pos, 2); - my $mult_exp := parse-simple-number(); - - parse_fail "'**' multiplier exponent must be an integer" - unless nqp::istype($mult_exp, Int); - - my $mult := $mult_base ** $mult_exp; - $int := $int * $mult; - $frac := $frac * $mult; - } - - # Return an Int if there was no radix point, otherwise, return a Rat - nqp::unless($base, $int, Rat.new($int * $base + $frac, $base)); - } - - # Look for radix specifiers - if nqp::iseq_i($ch, 58) { # ':' - # A string of the form :16 or :60[12,34,56] - $pos = nqp::add_i($pos, 1); - $parse := nqp::radix_I(10, $str, $pos, 0, Int); - $p = nqp::atpos($parse, 2); - parse_fail "radix (in decimal) expected after ':'" - if nqp::iseq_i($p, -1); - $pos = $p; - - $radix = nqp::atpos($parse, 0); - $ch = nqp::islt_i($pos, $eos) && nqp::ord($str, $pos); - if nqp::iseq_i($ch, 60) { # '<' - $pos = nqp::add_i($pos, 1); - - my $result := parse-int-frac-exp(); - - parse_fail "malformed ':$radix<>' style radix number, expecting '>' after the body" - unless nqp::islt_i($pos, $eos) - && nqp::iseq_i(nqp::ord($str, $pos), 62); # '>' - - $pos = nqp::add_i($pos, 1); - return $result; - } - elsif nqp::iseq_i($ch, 171) { # '«' - $pos = nqp::add_i($pos, 1); - - my $result := parse-int-frac-exp(); - - parse_fail "malformed ':$radix«»' style radix number, expecting '»' after the body" - unless nqp::islt_i($pos, $eos) - && nqp::iseq_i(nqp::ord($str, $pos), 187); # '»' - - $pos = nqp::add_i($pos, 1); - return $result; - } - elsif nqp::iseq_i($ch, 91) { # '[' - $pos = nqp::add_i($pos, 1); - my Int $result := 0; - my Int $digit := 0; - while nqp::islt_i($pos, $eos) - && nqp::isne_i(nqp::ord($str, $pos), 93) { # ']' - $parse := nqp::radix_I(10, $str, $pos, 0, Int); - $p = nqp::atpos($parse, 2); - parse_fail "malformed ':$radix[]' style radix number, expecting comma separated decimal values after opening '['" - if nqp::iseq_i($p, -1); - $pos = $p; - - $digit := nqp::atpos($parse, 0); - parse_fail "digit is larger than {$radix - 1} in ':$radix[]' style radix number" - if nqp::isge_i($digit, $radix); - - $result := $result * $radix + $digit; - $pos = nqp::add_i($pos, 1) - if nqp::islt_i($pos, $eos) - && nqp::iseq_i(nqp::ord($str, $pos), 44); # ',' - } - parse_fail "malformed ':$radix[]' style radix number, expecting ']' after the body" - unless nqp::islt_i($pos, $eos) - && nqp::iseq_i(nqp::ord($str, $pos), 93); # ']' - $pos = nqp::add_i($pos, 1); - - # XXXX: Handle fractions! - # XXXX: Handle exponents! - return $neg ?? -$result !! $result; - } - else { - parse_fail "malformed ':$radix' style radix number, expecting '<' or '[' after the base"; - } - } - elsif nqp::iseq_i($ch, 48) # '0' - and $radix = nqp::index(' b o d x', - nqp::substr($str, nqp::add_i($pos, 1), 1)) - and nqp::isge_i($radix, 2) { - # A string starting with 0x, 0d, 0o, or 0b, - # followed by one optional '_' - $pos = nqp::add_i($pos, 2); - $pos = nqp::add_i($pos, 1) - if nqp::islt_i($pos, $eos) - && nqp::iseq_i(nqp::ord($str, $pos), 95); # '_' - - parse-int-frac-exp(); - } - elsif nqp::eqat($str,'Inf',$pos) { - # 'Inf' - $pos = nqp::add_i($pos, 3); - $neg ?? -Inf !! Inf; - } - else { - # Last chance: a simple decimal number - $radix = 10; - parse-int-frac-exp(); - } - } - - my sub parse-real() { - # Parse a simple number or a Rat numerator - my $result := parse-simple-number(); - return $result if nqp::iseq_i($pos, $eos); - - # Check for '/' indicating Rat denominator - if nqp::iseq_i(nqp::ord($str, $pos), 47) { # '/' - $pos = nqp::add_i($pos, 1); - parse_fail "denominator expected after '/'" - unless nqp::islt_i($pos, $eos); - - my $denom := parse-simple-number(); - - $result := nqp::istype($result, Int) && nqp::istype($denom, Int) - ?? Rat.new($result, $denom) - !! $result / $denom; - } - - $result; - } - - # Parse a real number, magnitude of a pure imaginary number, - # or real part of a complex number - my $result := parse-real(); - parse_win $result if nqp::iseq_i($pos, $eos); - - # Check for 'i' or '\\i' indicating first parsed number was - # the magnitude of a pure imaginary number - if nqp::iseq_i(nqp::ord($str, $pos), 105) { # 'i' - parse_fail "Imaginary component of 'NaN' or 'Inf' must be followed by \\i" - if nqp::isnanorinf($result.Num); - $pos = nqp::add_i($pos, 1); - $result := Complex.new(0, $result); - } - elsif nqp::eqat($str,'\\i',$pos) { - $pos = nqp::add_i($pos, 2); - $result := Complex.new(0, $result); - } - # Check for '+' or '-' indicating first parsed number was - # the real part of a complex number - elsif nqp::iseq_i(nqp::ord($str, $pos), 45) # '-' - || nqp::iseq_i(nqp::ord($str, $pos), 43) # '+' - || nqp::iseq_i(nqp::ord($str, $pos), 8722) { # '−' - # Don't move $pos -- we want parse-real() to see the sign - my $im := parse-real(); - parse_fail "imaginary part of complex number must be followed by 'i' or '\\i'" - unless nqp::islt_i($pos, $eos); - - if nqp::iseq_i(nqp::ord($str, $pos), 105) { # 'i' - parse_fail "Imaginary component of 'NaN' or 'Inf' must be followed by \\i" - if nqp::isnanorinf($im.Num); - $pos = nqp::add_i($pos, 1); - } - elsif nqp::eqat($str,'\\i',$pos) { - $pos = nqp::add_i($pos, 2); - } - else { - parse_fail "imaginary part of complex number must be followed by 'i' or '\\i'" - } - - $result := Complex.new($result, $im); - } - - # Check for trailing garbage - parse_fail "trailing characters after number" - if nqp::islt_i($pos, $eos); - - parse_win $result; -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/allomorphs.pm6 rakudo-2018.03/src/core/allomorphs.pm6 --- rakudo-2018.02.1/src/core/allomorphs.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/allomorphs.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,571 @@ +# the uses of add_I in this class are a trick to make bigints work right +my class IntStr is Int is Str { + method new(Int:D $i, Str:D $s) { + my \SELF = nqp::add_I($i, 0, self); + nqp::bindattr_s(SELF, Str, '$!value', $s); + SELF; + } + multi method ACCEPTS(IntStr:D: Any:D \a) { + nqp::if( + nqp::istype(a, Numeric), + self.Int.ACCEPTS(a), + nqp::if( + nqp::istype(a, Str), + self.Str.ACCEPTS(a), + self.Str.ACCEPTS(a) && self.Int.ACCEPTS(a))) + } + multi method Numeric(IntStr:D:) { self.Int } + multi method Numeric(IntStr:U:) { + self.Mu::Numeric; # issue warning; + 0 + } + multi method Real(IntStr:D:) { self.Int } + multi method Real(IntStr:U:) { + self.Mu::Real; # issue warning; + 0 + } + method Int(IntStr:D:) { nqp::add_I(self, 0, Int) } + multi method Str(IntStr:D:) { nqp::getattr_s(self, Str, '$!value') } + + multi method perl(IntStr:D:) { self.^name ~ '.new(' ~ self.Int.perl ~ ', ' ~ self.Str.perl ~ ')' } +} + +my class NumStr is Num is Str { + method new(Num $n, Str $s) { + my \SELF = nqp::create(self); + nqp::bindattr_n(SELF, Num, '$!value', $n); + nqp::bindattr_s(SELF, Str, '$!value', $s); + SELF; + } + multi method ACCEPTS(NumStr:D: Any:D \a) { + nqp::if( + nqp::istype(a, Numeric), + self.Num.ACCEPTS(a), + nqp::if( + nqp::istype(a, Str), + self.Str.ACCEPTS(a), + self.Str.ACCEPTS(a) && self.Num.ACCEPTS(a))) + } + multi method Numeric(NumStr:D:) { self.Num } + multi method Numeric(NumStr:U:) { + self.Mu::Numeric; # issue warning; + 0e0 + } + multi method Real(NumStr:D:) { self.Num } + multi method Real(NumStr:U:) { + self.Mu::Real; # issue warning; + 0e0 + } + method Num(NumStr:D:) { nqp::getattr_n(self, Num, '$!value') } + multi method Str(NumStr:D:) { nqp::getattr_s(self, Str, '$!value') } + + multi method perl(NumStr:D:) { self.^name ~ '.new(' ~ self.Num.perl ~ ', ' ~ self.Str.perl ~ ')' } +} + +my class RatStr is Rat is Str { + method new(Rat $r, Str $s) { + my \SELF = nqp::create(self); + nqp::bindattr(SELF, Rat, '$!numerator', $r.numerator); + nqp::bindattr(SELF, Rat, '$!denominator', $r.denominator); + nqp::bindattr_s(SELF, Str, '$!value', $s); + SELF; + } + multi method ACCEPTS(RatStr:D: Any:D \a) { + nqp::if( + nqp::istype(a, Numeric), + self.Rat.ACCEPTS(a), + nqp::if( + nqp::istype(a, Str), + self.Str.ACCEPTS(a), + self.Str.ACCEPTS(a) && self.Rat.ACCEPTS(a))) + } + method succ(RatStr:D: --> Rat:D) { + nqp::p6bindattrinvres( + nqp::p6bindattrinvres(nqp::create(Rat), Rat, '$!numerator', + nqp::add_I( + nqp::getattr(self, Rat, '$!numerator'), + nqp::getattr(self, Rat, '$!denominator'), Int)), + Rat, '$!denominator', nqp::getattr(self, Rat, '$!denominator')) + } + method pred(RatStr:D: --> Rat:D) { + nqp::p6bindattrinvres( + nqp::p6bindattrinvres(nqp::create(Rat), Rat, '$!numerator', + nqp::sub_I( + nqp::getattr(self, Rat, '$!numerator'), + nqp::getattr(self, Rat, '$!denominator'), Int)), + Rat, '$!denominator', nqp::getattr(self, Rat, '$!denominator')) + } + method Capture(RatStr:D:) { self.Mu::Capture } + multi method Numeric(RatStr:D:) { self.Rat } + multi method Numeric(RatStr:U:) { + self.Mu::Numeric; # issue warning; + 0.0 + } + multi method Real(RatStr:D:) { self.Rat } + multi method Real(RatStr:U:) { + self.Mu::Real; # issue warning; + 0.0 + } + method Rat(RatStr:D:) { Rat.new(nqp::getattr(self, Rat, '$!numerator'), nqp::getattr(self, Rat, '$!denominator')) } + multi method Str(RatStr:D:) { nqp::getattr_s(self, Str, '$!value') } + + multi method perl(RatStr:D:) { self.^name ~ '.new(' ~ self.Rat.perl ~ ', ' ~ self.Str.perl ~ ')' } +} + +my class ComplexStr is Complex is Str { + method new(Complex $c, Str $s) { + my \SELF = nqp::create(self); + nqp::bindattr_n(SELF, Complex, '$!re', $c.re); + nqp::bindattr_n(SELF, Complex, '$!im', $c.im); + nqp::bindattr_s(SELF, Str, '$!value', $s); + SELF; + } + multi method ACCEPTS(ComplexStr:D: Any:D \a) { + nqp::if( + nqp::istype(a, Numeric), + self.Complex.ACCEPTS(a), + nqp::if( + nqp::istype(a, Str), + self.Str.ACCEPTS(a), + self.Str.ACCEPTS(a) && self.Complex.ACCEPTS(a))) + } + method Capture(ComplexStr:D:) { self.Mu::Capture } + multi method Numeric(ComplexStr:D:) { self.Complex } + multi method Numeric(ComplexStr:U:) { + self.Mu::Numeric; # issue warning; + <0+0i> + } + multi method Real(ComplexStr:D:) { self.Complex.Real } + multi method Real(ComplexStr:U:) { + self.Mu::Real; # issue warning; + <0+0i>.Real + } + method Complex(ComplexStr:D:) { Complex.new(nqp::getattr_n(self, Complex, '$!re'), nqp::getattr_n(self, Complex, '$!im')) } + multi method Str(ComplexStr:D:) { nqp::getattr_s(self, Str, '$!value') } + + multi method perl(ComplexStr:D:) { self.^name ~ '.new(' ~ self.Complex.perl ~ ', ' ~ self.Str.perl ~ ')' } +} + +# we define cmp ops for these allomorphic types as numeric first, then Str. If +# you want just one half of the cmp, you'll need to coerce the args +multi sub infix:(IntStr:D $a, IntStr:D $b) { $a.Int cmp $b.Int || $a.Str cmp $b.Str } +multi sub infix:(IntStr:D $a, RatStr:D $b) { $a.Int cmp $b.Rat || $a.Str cmp $b.Str } +multi sub infix:(IntStr:D $a, NumStr:D $b) { $a.Int cmp $b.Num || $a.Str cmp $b.Str } +multi sub infix:(IntStr:D $a, ComplexStr:D $b) { $a.Int cmp $b.Complex || $a.Str cmp $b.Str } + +multi sub infix:(RatStr:D $a, IntStr:D $b) { $a.Rat cmp $b.Int || $a.Str cmp $b.Str } +multi sub infix:(RatStr:D $a, RatStr:D $b) { $a.Rat cmp $b.Rat || $a.Str cmp $b.Str } +multi sub infix:(RatStr:D $a, NumStr:D $b) { $a.Rat cmp $b.Num || $a.Str cmp $b.Str } +multi sub infix:(RatStr:D $a, ComplexStr:D $b) { $a.Rat cmp $b.Complex || $a.Str cmp $b.Str } + +multi sub infix:(NumStr:D $a, IntStr:D $b) { $a.Num cmp $b.Int || $a.Str cmp $b.Str } +multi sub infix:(NumStr:D $a, RatStr:D $b) { $a.Num cmp $b.Rat || $a.Str cmp $b.Str } +multi sub infix:(NumStr:D $a, NumStr:D $b) { $a.Num cmp $b.Num || $a.Str cmp $b.Str } +multi sub infix:(NumStr:D $a, ComplexStr:D $b) { $a.Num cmp $b.Complex || $a.Str cmp $b.Str } + +multi sub infix:(ComplexStr:D $a, IntStr:D $b) { $a.Complex cmp $b.Int || $a.Str cmp $b.Str } +multi sub infix:(ComplexStr:D $a, RatStr:D $b) { $a.Complex cmp $b.Rat || $a.Str cmp $b.Str } +multi sub infix:(ComplexStr:D $a, NumStr:D $b) { $a.Complex cmp $b.Num || $a.Str cmp $b.Str } +multi sub infix:(ComplexStr:D $a, ComplexStr:D $b) { $a.Complex cmp $b.Complex || $a.Str cmp $b.Str } + + +multi sub infix:(IntStr:D $a, IntStr:D $b) { $a.Int eqv $b.Int && $a.Str eqv $b.Str } +multi sub infix:(IntStr:D $a, RatStr:D $b --> False) {} +multi sub infix:(IntStr:D $a, NumStr:D $b --> False) {} +multi sub infix:(IntStr:D $a, ComplexStr:D $b --> False) {} + +multi sub infix:(RatStr:D $a, IntStr:D $b --> False) {} +multi sub infix:(RatStr:D $a, RatStr:D $b) { $a.Rat eqv $b.Rat && $a.Str eqv $b.Str } +multi sub infix:(RatStr:D $a, NumStr:D $b --> False) {} +multi sub infix:(RatStr:D $a, ComplexStr:D $b --> False) {} + +multi sub infix:(NumStr:D $a, IntStr:D $b --> False) {} +multi sub infix:(NumStr:D $a, RatStr:D $b --> False) {} +multi sub infix:(NumStr:D $a, NumStr:D $b) { $a.Num eqv $b.Num && $a.Str eqv $b.Str } +multi sub infix:(NumStr:D $a, ComplexStr:D $b --> False) {} + +multi sub infix:(ComplexStr:D $a, IntStr:D $b --> False) {} +multi sub infix:(ComplexStr:D $a, RatStr:D $b --> False) {} +multi sub infix:(ComplexStr:D $a, NumStr:D $b --> False) {} +multi sub infix:(ComplexStr:D $a, ComplexStr:D $b) { $a.Complex eqv $b.Complex && $a.Str eqv $b.Str } + +multi sub infix:<===>(IntStr:D $a, IntStr:D $b) { + $a.Int === $b.Int && $a.Str === $b.Str +} +multi sub infix:<===>(RatStr:D $a, RatStr:D $b) { + $a.Rat === $b.Rat && $a.Str === $b.Str +} +multi sub infix:<===>(NumStr:D $a, NumStr:D $b) { + $a.Num === $b.Num && $a.Str === $b.Str +} +multi sub infix:<===>(ComplexStr:D $a, ComplexStr:D $b) { + $a.Complex === $b.Complex && $a.Str === $b.Str +} + +multi sub val(*@maybevals) { + @maybevals.list.map({ val($_) }).eager; +} + +multi sub val(Mu) { + warn "Value of type Mu uselessly passed to val()"; + Mu +} + +# if Slip, preserve slipness +multi sub val(List:D $maybevals) { + nqp::stmts( + (my $output := val(|$maybevals)), + nqp::if( + nqp::istype($maybevals, Slip), + $output.Slip, + $output + ) + ) +} + +multi sub val(Pair:D \ww-thing) is raw { + # this is a Pair object possible in «» constructs; just pass it through. We + # capture this specially from the below sub to avoid emitting a warning + # whenever an affected «» construct is being processed. + + ww-thing +} + +multi sub val(\one-thing) { + warn "Value of type {one-thing.WHAT.perl} uselessly passed to val()"; + one-thing; +} + +multi sub val(Str:D $MAYBEVAL, :$val-or-fail) { + # TODO: + # * Additional numeric styles: + # + fractions in [] radix notation: :100[10,'.',53] + # * Performance tuning + # * Fix remaining XXXX + + my str $str = nqp::unbox_s($MAYBEVAL); + my int $eos = nqp::chars($str); + return IntStr.new(0,"") unless $eos; # handle "" + + # S02:3276-3277: Ignore leading and trailing whitespace + my int $pos = nqp::findnotcclass(nqp::const::CCLASS_WHITESPACE, + $str, 0, $eos); + my int $end = nqp::sub_i($eos, 1); + + $end = nqp::sub_i($end, 1) + while nqp::isge_i($end, $pos) + && nqp::iscclass(nqp::const::CCLASS_WHITESPACE, $str, $end); + + # Fail all the way out when parse failures occur. Return the original + # string, or a failure if we're Str.Numeric + my &parse_fail := -> \msg { + $val-or-fail + ?? fail X::Str::Numeric.new(:source($MAYBEVAL),:reason(msg),:$pos) + !! return $MAYBEVAL + } + + # Str.Numeric should handle blank string before val() + parse_fail "Empty string not properly caught before val()" if nqp::islt_i($end, $pos); + + # Reset end-of-string after trimming + $eos = nqp::add_i($end, 1); + + # return an appropriate type when we've found a number. Allomorphic unless + # Str.Numeric is calling + my &parse_win := -> \newval { + $val-or-fail + ?? return newval + !! nqp::istype(newval, Num) + ?? return NumStr.new(newval, $MAYBEVAL) + !! nqp::istype(newval, Rat) + ?? return RatStr.new(newval, $MAYBEVAL) + !! nqp::istype(newval, Complex) + ?? return ComplexStr.new(newval, $MAYBEVAL) + !! nqp::istype(newval, Int) + ?? return IntStr.new(newval, $MAYBEVAL) + !! die "Unknown type {newval.^name} found in val() processing" + } + + my sub parse-simple-number() { + # Handle NaN here, to make later parsing simpler + if nqp::eqat($str,'NaN',$pos) { + $pos = nqp::add_i($pos, 3); + return nqp::p6box_n(nqp::nan()); + } + + # Handle any leading +/-/− sign + my int $ch = nqp::ord($str, $pos); + my int $neg = nqp::iseq_i($ch, 45) || nqp::iseq_i($ch, 8722); # '-', '−' + if $neg || nqp::iseq_i($ch, 43) { # '-', '−', '+' + $pos = nqp::add_i($pos, 1); + $ch = nqp::islt_i($pos, $eos) && nqp::ord($str, $pos); + } + + # nqp::radix_I parse results, and helper values + my Mu $parse; + my str $prefix; + my int $radix; + my int $p; + + my sub parse-int-frac-exp() { + # Integer part, if any + my Int $int := 0; + if nqp::isne_i($ch, 46) { # '.' + parse_fail "Cannot convert radix of $radix (max 36)" + if nqp::isgt_i($radix, 36); + $parse := nqp::radix_I($radix, $str, $pos, $neg, Int); + $p = nqp::atpos($parse, 2); + parse_fail "base-$radix number must begin with valid digits or '.'" + if nqp::iseq_i($p, -1); + $pos = $p; + + $int := nqp::atpos($parse, 0); + nqp::isge_i($pos, $eos) + ?? return $int + !! ($ch = nqp::ord($str, $pos)); + } + + # Fraction, if any + my Int $frac := 0; + my Int $base := 0; + if nqp::iseq_i($ch, 46) { # '.' + $pos = nqp::add_i($pos, 1); + $parse := nqp::radix_I($radix, $str, $pos, + nqp::add_i($neg, 4), Int); + $p = nqp::atpos($parse, 2); + parse_fail 'radix point must be followed by one or more valid digits' + if nqp::iseq_i($p, -1); + $pos = $p; + + $frac := nqp::atpos($parse, 0); + $base := nqp::atpos($parse, 1); + $ch = nqp::islt_i($pos, $eos) && nqp::ord($str, $pos); + } + + # Exponent, if 'E' or 'e' are present (forces return type Num) + if nqp::iseq_i($ch, 69) || nqp::iseq_i($ch, 101) { # 'E', 'e' + parse_fail "'E' or 'e' style exponent only allowed on decimal (base-10) numbers, not base-$radix" + unless nqp::iseq_i($radix, 10); + + $pos = nqp::add_i($pos, 1); + # handle the sign + # XXX TODO: teach radix_I to handle '−' (U+2212) minus? + my int $ch = nqp::islt_i($pos, $eos) && nqp::ord($str, $pos); + my int $neg-e = nqp::if( + nqp::iseq_i($ch, 43), # '+' + nqp::stmts(($pos = nqp::add_i($pos, 1)), 0), + nqp::if( # '-', '−' + nqp::iseq_i($ch, 45) || nqp::iseq_i($ch, 8722), + nqp::stmts(($pos = nqp::add_i($pos, 1)), 1), + 0, + ) + ); + + $parse := nqp::radix_I(10, $str, $pos, $neg-e, Int); + $p = nqp::atpos($parse, 2); + parse_fail "'E' or 'e' must be followed by decimal (base-10) integer" + if nqp::iseq_i($p, -1); + $pos = $p; + + return nqp::p6box_n(nqp::mul_n( + $frac ?? nqp::add_n( $int.Num, nqp::div_n($frac.Num, $base.Num) ) + !! $int.Num, + nqp::pow_n(10e0, nqp::atpos($parse, 0).Num) + )) # if we have a zero, handle the sign correctly + || nqp::if(nqp::iseq_i($neg, 1), -0e0, 0e0); + } + + # Multiplier with exponent, if single '*' is present + # (but skip if current token is '**', as otherwise we + # get recursive multiplier parsing stupidity) + if nqp::iseq_i($ch, 42) + && nqp::isne_s(substr($str, $pos, 2), '**') { # '*' + $pos = nqp::add_i($pos, 1); + my $mult_base := parse-simple-number(); + + parse_fail "'*' multiplier base must be an integer" + unless nqp::istype($mult_base, Int); + parse_fail "'*' multiplier base must be followed by '**' and exponent" + unless nqp::eqat($str,'**',$pos); + + $pos = nqp::add_i($pos, 2); + my $mult_exp := parse-simple-number(); + + parse_fail "'**' multiplier exponent must be an integer" + unless nqp::istype($mult_exp, Int); + + my $mult := $mult_base ** $mult_exp; + $int := $int * $mult; + $frac := $frac * $mult; + } + + # Return an Int if there was no radix point, otherwise, return a Rat + nqp::unless($base, $int, Rat.new($int * $base + $frac, $base)); + } + + # Look for radix specifiers + if nqp::iseq_i($ch, 58) { # ':' + # A string of the form :16 or :60[12,34,56] + $pos = nqp::add_i($pos, 1); + $parse := nqp::radix_I(10, $str, $pos, 0, Int); + $p = nqp::atpos($parse, 2); + parse_fail "radix (in decimal) expected after ':'" + if nqp::iseq_i($p, -1); + $pos = $p; + + $radix = nqp::atpos($parse, 0); + $ch = nqp::islt_i($pos, $eos) && nqp::ord($str, $pos); + if nqp::iseq_i($ch, 60) { # '<' + $pos = nqp::add_i($pos, 1); + + my $result := parse-int-frac-exp(); + + parse_fail "malformed ':$radix<>' style radix number, expecting '>' after the body" + unless nqp::islt_i($pos, $eos) + && nqp::iseq_i(nqp::ord($str, $pos), 62); # '>' + + $pos = nqp::add_i($pos, 1); + return $result; + } + elsif nqp::iseq_i($ch, 171) { # '«' + $pos = nqp::add_i($pos, 1); + + my $result := parse-int-frac-exp(); + + parse_fail "malformed ':$radix«»' style radix number, expecting '»' after the body" + unless nqp::islt_i($pos, $eos) + && nqp::iseq_i(nqp::ord($str, $pos), 187); # '»' + + $pos = nqp::add_i($pos, 1); + return $result; + } + elsif nqp::iseq_i($ch, 91) { # '[' + $pos = nqp::add_i($pos, 1); + my Int $result := 0; + my Int $digit := 0; + while nqp::islt_i($pos, $eos) + && nqp::isne_i(nqp::ord($str, $pos), 93) { # ']' + $parse := nqp::radix_I(10, $str, $pos, 0, Int); + $p = nqp::atpos($parse, 2); + parse_fail "malformed ':$radix[]' style radix number, expecting comma separated decimal values after opening '['" + if nqp::iseq_i($p, -1); + $pos = $p; + + $digit := nqp::atpos($parse, 0); + parse_fail "digit is larger than {$radix - 1} in ':$radix[]' style radix number" + if nqp::isge_i($digit, $radix); + + $result := $result * $radix + $digit; + $pos = nqp::add_i($pos, 1) + if nqp::islt_i($pos, $eos) + && nqp::iseq_i(nqp::ord($str, $pos), 44); # ',' + } + parse_fail "malformed ':$radix[]' style radix number, expecting ']' after the body" + unless nqp::islt_i($pos, $eos) + && nqp::iseq_i(nqp::ord($str, $pos), 93); # ']' + $pos = nqp::add_i($pos, 1); + + # XXXX: Handle fractions! + # XXXX: Handle exponents! + return $neg ?? -$result !! $result; + } + else { + parse_fail "malformed ':$radix' style radix number, expecting '<' or '[' after the base"; + } + } + elsif nqp::iseq_i($ch, 48) # '0' + and $radix = nqp::index(' b o d x', + nqp::substr($str, nqp::add_i($pos, 1), 1)) + and nqp::isge_i($radix, 2) { + # A string starting with 0x, 0d, 0o, or 0b, + # followed by one optional '_' + $pos = nqp::add_i($pos, 2); + $pos = nqp::add_i($pos, 1) + if nqp::islt_i($pos, $eos) + && nqp::iseq_i(nqp::ord($str, $pos), 95); # '_' + + parse-int-frac-exp(); + } + elsif nqp::eqat($str,'Inf',$pos) { + # 'Inf' + $pos = nqp::add_i($pos, 3); + $neg ?? -Inf !! Inf; + } + else { + # Last chance: a simple decimal number + $radix = 10; + parse-int-frac-exp(); + } + } + + my sub parse-real() { + # Parse a simple number or a Rat numerator + my $result := parse-simple-number(); + return $result if nqp::iseq_i($pos, $eos); + + # Check for '/' indicating Rat denominator + if nqp::iseq_i(nqp::ord($str, $pos), 47) { # '/' + $pos = nqp::add_i($pos, 1); + parse_fail "denominator expected after '/'" + unless nqp::islt_i($pos, $eos); + + my $denom := parse-simple-number(); + + $result := nqp::istype($result, Int) && nqp::istype($denom, Int) + ?? Rat.new($result, $denom) + !! $result / $denom; + } + + $result; + } + + # Parse a real number, magnitude of a pure imaginary number, + # or real part of a complex number + my $result := parse-real(); + parse_win $result if nqp::iseq_i($pos, $eos); + + # Check for 'i' or '\\i' indicating first parsed number was + # the magnitude of a pure imaginary number + if nqp::iseq_i(nqp::ord($str, $pos), 105) { # 'i' + parse_fail "Imaginary component of 'NaN' or 'Inf' must be followed by \\i" + if nqp::isnanorinf($result.Num); + $pos = nqp::add_i($pos, 1); + $result := Complex.new(0, $result); + } + elsif nqp::eqat($str,'\\i',$pos) { + $pos = nqp::add_i($pos, 2); + $result := Complex.new(0, $result); + } + # Check for '+' or '-' indicating first parsed number was + # the real part of a complex number + elsif nqp::iseq_i(nqp::ord($str, $pos), 45) # '-' + || nqp::iseq_i(nqp::ord($str, $pos), 43) # '+' + || nqp::iseq_i(nqp::ord($str, $pos), 8722) { # '−' + # Don't move $pos -- we want parse-real() to see the sign + my $im := parse-real(); + parse_fail "imaginary part of complex number must be followed by 'i' or '\\i'" + unless nqp::islt_i($pos, $eos); + + if nqp::iseq_i(nqp::ord($str, $pos), 105) { # 'i' + parse_fail "Imaginary component of 'NaN' or 'Inf' must be followed by \\i" + if nqp::isnanorinf($im.Num); + $pos = nqp::add_i($pos, 1); + } + elsif nqp::eqat($str,'\\i',$pos) { + $pos = nqp::add_i($pos, 2); + } + else { + parse_fail "imaginary part of complex number must be followed by 'i' or '\\i'" + } + + $result := Complex.new($result, $im); + } + + # Check for trailing garbage + parse_fail "trailing characters after number" + if nqp::islt_i($pos, $eos); + + parse_win $result; +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Any-iterable-methods.pm rakudo-2018.03/src/core/Any-iterable-methods.pm --- rakudo-2018.02.1/src/core/Any-iterable-methods.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Any-iterable-methods.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,2012 +0,0 @@ -# Now that Iterable is defined, we add extra methods into Any for the list -# operations. (They can't go into Any right away since we need Attribute to -# define the various roles, and Attribute inherits from Any. We will do a -# re-compose of Attribute to make sure it gets the list methods at the end -# of this file. Note the general pattern for these list-y methods is that -# they check if they have an Iterable already, and if not obtain one to -# work on by doing a .list coercion. -use MONKEY-TYPING; -augment class Any { - - proto method map(|) is nodal {*} - multi method map(Hash \h) { - die "Cannot map a {self.^name} to a {h.^name}. -Did you mean to add a stub (\{...\}) or did you mean to .classify?" - } - - multi method map(\SELF: █; :$label, :$item) { - sequential-map(($item ?? (SELF,) !! SELF).iterator, &block, $label); - } - - my class IterateOneWithPhasers does SlippyIterator { - has &!block; - has $!source; - has $!label; - has Int $!NEXT; # SHOULD BE int, but has Int performs better - has Int $!did-init; # SHOULD BE int, but has Int performs better - has Int $!did-iterate; # SHOULD BE int, but has Int performs better - - method !SET-SELF(\block,\source,\label) { - nqp::stmts( - (&!block := block), - ($!source := source), - ($!label := label), - ($!NEXT = block.has-phaser('NEXT')), - self - ) - } - method new(\bl,\sou,\la) { nqp::create(self)!SET-SELF(bl,sou,la) } - - method is-lazy() { $!source.is-lazy } - - method pull-one() is raw { - my int $stopped; - my $value; - my $result; - - nqp::unless( - $!did-init, - nqp::stmts( - ($!did-init = 1), - nqp::if( - &!block.has-phaser('FIRST'), - nqp::p6setfirstflag(&!block) - ) - ) - ); - - if $!slipping && nqp::not_i(nqp::eqaddr(($result := self.slip-one),IterationEnd)) { - # $result will be returned at the end - } - elsif nqp::eqaddr(($value := $!source.pull-one),IterationEnd) { - $result := IterationEnd - } - else { - nqp::until( - $stopped, - nqp::handle( - nqp::stmts( - ($stopped = 1), - ($result := &!block($value)), - ($!did-iterate = 1), - nqp::if( - nqp::istype($result, Slip), - nqp::if( - nqp::eqaddr(($result := self.start-slip($result)), IterationEnd), - nqp::if( - nqp::not_i(nqp::eqaddr(($value := $!source.pull-one),IterationEnd)), - ($stopped = 0) - ), - ) - ), - nqp::if($!NEXT, &!block.fire_phasers('NEXT')), - ), - 'LABELED', $!label, - 'NEXT', nqp::stmts( - ($!did-iterate = 1), - nqp::if($!NEXT, &!block.fire_phasers('NEXT')), - nqp::eqaddr(($value := $!source.pull-one), IterationEnd) - ?? ($result := IterationEnd) - !! ($stopped = 0) - ), - 'REDO', ($stopped = 0), - 'LAST', nqp::stmts( - ($!did-iterate = 1), - ($result := IterationEnd) - ) - ), - :nohandler - ) - } - nqp::if( - $!did-iterate && nqp::eqaddr($result,IterationEnd), - &!block.fire_if_phasers('LAST') - ); - $result - } - - method push-all($target --> IterationEnd) { - nqp::unless( - $!did-init, - nqp::stmts( - ($!did-init = 1), - nqp::if( - &!block.has-phaser('FIRST'), - nqp::p6setfirstflag(&!block) - ) - ) - ); - - my int $stopped; - my int $done; - my $pulled; - my $value; - - nqp::if( - $!slipping, - nqp::until( - nqp::eqaddr(($value := self.slip-one),IterationEnd), - $target.push($value) - ) - ); - - until $done - || nqp::eqaddr(($value := $!source.pull-one),IterationEnd) { - nqp::stmts( - ($stopped = 0), - nqp::until( - $stopped, - nqp::stmts( - ($stopped = 1), - nqp::handle( - nqp::stmts( # doesn't sink - ($pulled := &!block($value)), - ($!did-iterate = 1), - nqp::if($!NEXT, &!block.fire_phasers('NEXT')), - nqp::if( - nqp::istype($pulled,Slip), - self.slip-all($pulled,$target), - $target.push($pulled) - ) - ), - 'LABELED', $!label, - 'NEXT', nqp::stmts( - ($!did-iterate = 1), - nqp::if($!NEXT, &!block.fire_phasers('NEXT')), - nqp::eqaddr( - ($value := $!source.pull-one), - IterationEnd - ) - ?? ($done = 1) - !! ($stopped = 0)), - 'REDO', ($stopped = 0), - 'LAST', ($done = $!did-iterate = 1) - ) - ), - :nohandler - ) - ) - } - nqp::if($!did-iterate,&!block.fire_if_phasers('LAST')) - } - - method sink-all(--> IterationEnd) { - nqp::unless( - $!did-init, - nqp::stmts( - ($!did-init = 1), - nqp::if( - &!block.has-phaser('FIRST'), - nqp::p6setfirstflag(&!block) - ) - ) - ); - - nqp::if( - $!slipping, - nqp::until( - nqp::eqaddr(self.slip-one,IterationEnd), - nqp::null - ) - ); - - my int $stopped; - my int $done; - my $value; - until $done - || nqp::eqaddr(($value := $!source.pull-one()),IterationEnd) { - nqp::stmts( - ($stopped = 0), - nqp::until( - $stopped, - nqp::stmts( - ($stopped = 1), - nqp::handle( - nqp::stmts( # doesn't sink - (&!block($value)), - ($!did-iterate = 1), - nqp::if($!NEXT, &!block.fire_phasers('NEXT')), - ), - 'LABELED', $!label, - 'NEXT', nqp::stmts( - ($!did-iterate = 1), - nqp::if($!NEXT, &!block.fire_phasers('NEXT')), - nqp::eqaddr( - ($value := $!source.pull-one), - IterationEnd - ) - ?? ($done = 1) - !! ($stopped = 0)), - 'REDO', ($stopped = 0), - 'LAST', ($done = $!did-iterate = 1) - ) - ), - :nohandler - ) - ) - } - nqp::if($!did-iterate,&!block.fire_if_phasers('LAST')) - } - } - - my class IterateOneNotSlippingWithoutPhasers does Iterator { - has &!block; - has $!source; - has $!label; - - method new(&block,$source,$label) { - my $iter := nqp::create(self); - nqp::bindattr($iter, self, '&!block', &block); - nqp::bindattr($iter, self, '$!source', $source); - nqp::bindattr($iter, self, '$!label', nqp::decont($label)); - $iter - } - - method is-lazy() { $!source.is-lazy } - - method pull-one() is raw { - if nqp::eqaddr((my $pulled := $!source.pull-one),IterationEnd) { - IterationEnd - } - else { - my $result; - my int $stopped; - nqp::stmts( - nqp::until( - $stopped, - nqp::stmts( - ($stopped = 1), - nqp::handle( - ($result := &!block($pulled)), - 'LABELED', $!label, - 'NEXT', nqp::if( - nqp::eqaddr( - ($pulled := $!source.pull-one), - IterationEnd - ), - ($result := IterationEnd), - ($stopped = 0) - ), - 'REDO', ($stopped = 0), - 'LAST', ($result := IterationEnd) - ), - ), - :nohandler - ), - $result - ) - } - } - - method push-all($target --> IterationEnd) { - my $pulled; - my int $stopped; - nqp::until( - nqp::eqaddr(($pulled := $!source.pull-one),IterationEnd), - nqp::stmts( - ($stopped = 0), - nqp::until( - $stopped, - nqp::stmts( - ($stopped = 1), - nqp::handle( - $target.push(&!block($pulled)), - 'LABELED', $!label, - 'REDO', ($stopped = 0), - 'NEXT', nqp::null, # need NEXT for next LABEL support - 'LAST', return - ) - ), - :nohandler - ) - ) - ) - } - - method sink-all(--> IterationEnd) { - my $pulled; - my int $stopped; - nqp::until( - nqp::eqaddr(($pulled := $!source.pull-one),IterationEnd), - nqp::stmts( - ($stopped = 0), - nqp::until( - $stopped, - nqp::stmts( - ($stopped = 1), - nqp::handle( - &!block($pulled), - 'LABELED', $!label, - 'REDO', ($stopped = 0), - 'NEXT', nqp::null, # need NEXT for next LABEL support - 'LAST', return - ) - ), - :nohandler - ) - ) - ) - } - } - - my class IterateOneWithoutPhasers does SlippyIterator { - has &!block; - has $!source; - has $!label; - - method new(&block,$source,$label) { - my $iter := nqp::create(self); - nqp::bindattr($iter, self, '&!block', &block); - nqp::bindattr($iter, self, '$!source', $source); - nqp::bindattr($iter, self, '$!label', nqp::decont($label)); - $iter - } - - method is-lazy() { $!source.is-lazy } - - method pull-one() is raw { - my int $redo = 1; - my $value; - my $result; - - if $!slipping && nqp::not_i(nqp::eqaddr( - ($result := self.slip-one), - IterationEnd - )) { - # $result will be returned at the end - } - elsif nqp::eqaddr( - ($value := $!source.pull-one), - IterationEnd - ) { - $result := $value - } - else { - nqp::while( - $redo, - nqp::stmts( - $redo = 0, - nqp::handle( - nqp::if( - nqp::istype(($result := &!block($value)),Slip), - nqp::if( - nqp::eqaddr( - ($result := self.start-slip($result)), IterationEnd), - nqp::if( - nqp::not_i(nqp::eqaddr( - ($value := $!source.pull-one), - IterationEnd - )), - $redo = 1 - ) - ) - ), - 'LABELED', - $!label, - 'NEXT', - nqp::if( - nqp::eqaddr( - ($value := $!source.pull-one),IterationEnd - ), - ($result := IterationEnd), - ($redo = 1) - ), - 'REDO', - ($redo = 1), - 'LAST', - ($result := IterationEnd) - ), - ), - :nohandler); - } - $result - } - - method push-all($target --> IterationEnd) { - nqp::stmts( - (my $value), - nqp::if( - $!slipping, - nqp::until( - nqp::eqaddr(($value := self.slip-one),IterationEnd), - $target.push($value) - ) - ), - nqp::until( - nqp::eqaddr(($value := $!source.pull-one),IterationEnd), - nqp::stmts( - (my int $redo = 1), - nqp::while( - $redo, - nqp::stmts( - ($redo = 0), - nqp::handle( - nqp::if( - nqp::istype((my $result := &!block($value)),Slip), - self.slip-all($result,$target), - $target.push($result) - ), - 'LABELED', $!label, - 'REDO', ($redo = 1), - 'LAST', return, - 'NEXT', nqp::null, # need NEXT for next LABEL support - ) - ), - :nohandler - ) - ) - ) - ) - } - - method sink-all(--> IterationEnd) { - nqp::stmts( - nqp::if( - $!slipping, - nqp::until( - nqp::eqaddr(self.slip-one,IterationEnd), - nqp::null - ) - ), - nqp::until( - nqp::eqaddr((my $value := $!source.pull-one()),IterationEnd), - nqp::stmts( - (my int $redo = 1), - nqp::while( - $redo, - nqp::stmts( - ($redo = 0), - nqp::handle( # doesn't sink - &!block($value), - 'LABELED', $!label, - 'NEXT', nqp::null, # need NEXT for next LABEL support - 'REDO', ($redo = 1), - 'LAST', return - ), - :nohandler - ) - ) - ) - ) - ) - } - } - - my class IterateTwoWithoutPhasers does SlippyIterator { - has &!block; - has $!source; - has $!label; - - method new(&block,$source,$label) { - my $iter := nqp::create(self); - nqp::bindattr($iter, self, '&!block', &block); - nqp::bindattr($iter, self, '$!source', $source); - nqp::bindattr($iter, self, '$!label', nqp::decont($label)); - $iter - } - - method is-lazy() { $!source.is-lazy } - - method pull-one() is raw { - my int $redo = 1; - my $value; - my $value2; - my $result; - - if $!slipping && nqp::not_i(nqp::eqaddr( - ($result := self.slip-one), - IterationEnd - )) { - # $result will be returned at the end - } - elsif nqp::eqaddr( - ($value := $!source.pull-one), - IterationEnd - ) { - $result := IterationEnd; - } - else { - nqp::while( - $redo, - nqp::stmts( - $redo = 0, - nqp::handle( - nqp::stmts( - nqp::if( - nqp::eqaddr(($value2 := $!source.pull-one),IterationEnd), - nqp::if( # don't have 2 params - nqp::istype(($result := &!block($value)),Slip), - ($result := self.start-slip($result)) # don't care if empty - ), - nqp::if( - nqp::istype(($result := &!block($value,$value2)),Slip), - nqp::if( - nqp::eqaddr(($result := self.start-slip($result)),IterationEnd), - nqp::unless( - nqp::eqaddr(($value := $!source.pull-one),IterationEnd), - ($redo = 1) - ) - ) - ) - ) - ), - 'LABELED', - $!label, - 'NEXT', - nqp::if( - nqp::eqaddr( - ($value := $!source.pull-one),IterationEnd - ), - ($result := IterationEnd), - ($redo = 1) - ), - 'REDO', - ($redo = 1), - 'LAST', - ($result := IterationEnd) - ), - ), - :nohandler); - } - $result - } - - method push-all($target --> IterationEnd) { - nqp::stmts( - (my $value), - nqp::if( - $!slipping, - nqp::until( - nqp::eqaddr(($value := self.slip-one),IterationEnd), - $target.push($value) - ) - ), - nqp::until( - nqp::eqaddr(($value := $!source.pull-one),IterationEnd), - nqp::stmts( - (my int $redo = 1), - nqp::while( - $redo, - nqp::stmts( - ($redo = 0), - nqp::handle( - nqp::if( - nqp::eqaddr( - (my $value2 := $!source.pull-one), - IterationEnd - ), - nqp::stmts( - (my $result := &!block($value)), - nqp::if( - nqp::istype($result,Slip), - self.slip-all($result,$target), - $target.push($result) - ), - return - ), - nqp::if( - nqp::istype( - ($result := &!block($value,$value2)), - Slip - ), - self.slip-all($result,$target), - $target.push($result) - ) - ), - 'LABELED', $!label, - 'REDO', ($redo = 1), - 'LAST', return, - 'NEXT', nqp::null, # need NEXT for next LABEL support - ) - ), - :nohandler - ) - ) - ) - ) - } - - method sink-all(--> IterationEnd) { - nqp::stmts( - nqp::if( - $!slipping, - nqp::until( - nqp::eqaddr(self.slip-one,IterationEnd), - nqp::null, - ) - ), - nqp::until( - nqp::eqaddr((my $value := $!source.pull-one()),IterationEnd), - nqp::stmts( - (my int $redo = 1), - nqp::while( - $redo, - nqp::stmts( - ($redo = 0), - nqp::handle( # doesn't sink - nqp::if( - nqp::eqaddr( - (my $value2 := $!source.pull-one), - IterationEnd - ), - nqp::stmts( - (&!block($value)), - return - ), - (&!block($value,$value2)) - ), - 'LABELED', $!label, - 'NEXT', nqp::null, # need NEXT for next LABEL support - 'REDO', ($redo = 1), - 'LAST', return - ) - ), - :nohandler - ) - ) - ) - ) - } - } - - my class IterateMoreWithPhasers does SlippyIterator { - has &!block; - has $!source; - has $!count; - has $!label; - has $!value-buffer; - has $!did-init; - has $!did-iterate; - has $!NEXT; - has $!CAN_FIRE_PHASERS; - - method new(&block, $source, $count, $label) { - my $iter := nqp::create(self); - nqp::bindattr($iter, self, '&!block', &block); - nqp::bindattr($iter, self, '$!source', $source); - nqp::bindattr($iter, self, '$!count', $count); - nqp::bindattr($iter, self, '$!label', nqp::decont($label)); - $iter - } - - method is-lazy() { $!source.is-lazy } - - method pull-one() is raw { - $!value-buffer.DEFINITE - ?? nqp::setelems($!value-buffer, 0) - !! ($!value-buffer := IterationBuffer.new); - my int $redo = 1; - my $result; - - if !$!did-init && nqp::can(&!block, 'fire_phasers') { - $!did-init = 1; - $!CAN_FIRE_PHASERS = 1; - $!NEXT = &!block.has-phaser('NEXT'); - nqp::p6setfirstflag(&!block) - if &!block.has-phaser('FIRST'); - } - - if $!slipping && !(($result := self.slip-one()) =:= IterationEnd) { - # $result will be returned at the end - } - elsif $!source.push-exactly($!value-buffer, $!count) =:= IterationEnd - && nqp::elems($!value-buffer) == 0 { - $result := IterationEnd - } - else { - nqp::while( - $redo, - nqp::stmts( - $redo = 0, - nqp::handle( - nqp::stmts( - ($result := nqp::p6invokeflat(&!block, $!value-buffer)), - ($!did-iterate = 1), - nqp::if( - nqp::istype($result, Slip), - nqp::stmts( - ($result := self.start-slip($result)), - nqp::if( - nqp::eqaddr($result, IterationEnd), - nqp::stmts( - (nqp::setelems($!value-buffer, 0)), - ($redo = 1 - unless nqp::eqaddr( - $!source.push-exactly($!value-buffer, $!count), - IterationEnd) - && nqp::elems($!value-buffer) == 0) - ) - ) - ) - ), - nqp::if($!NEXT, &!block.fire_phasers('NEXT')), - ), - 'LABELED', $!label, - 'NEXT', nqp::stmts( - ($!did-iterate = 1), - nqp::if($!NEXT, &!block.fire_phasers('NEXT')), - (nqp::setelems($!value-buffer, 0)), - nqp::eqaddr($!source.push-exactly($!value-buffer, $!count), IterationEnd) - && nqp::elems($!value-buffer) == 0 - ?? ($result := IterationEnd) - !! ($redo = 1)), - 'REDO', $redo = 1, - 'LAST', nqp::stmts( - ($!did-iterate = 1), - ($result := IterationEnd) - ) - ) - ), - :nohandler); - } - &!block.fire_if_phasers('LAST') - if $!CAN_FIRE_PHASERS - && $!did-iterate - && nqp::eqaddr($result, IterationEnd); - $result - } - } - - sub sequential-map(\source, &block, $label) { - # We want map to be fast, so we go to some effort to build special - # case iterators that can ignore various interesting cases. - my $count = &block.count; - - Seq.new( - nqp::istype(&block,Block) && &block.has-phasers - ?? $count < 2 || $count === Inf - ?? IterateOneWithPhasers.new(&block,source,$label) - !! IterateMoreWithPhasers.new(&block,source,$count,$label) - !! $count < 2 || $count === Inf - ?? nqp::istype(Slip,&block.returns) - ?? IterateOneWithoutPhasers.new(&block,source,$label) - !! IterateOneNotSlippingWithoutPhasers.new(&block,source,$label) - !! $count == 2 - ?? IterateTwoWithoutPhasers.new(&block,source,$label) - !! IterateMoreWithPhasers.new(&block,source,$count,$label) - ) - } - - proto method flatmap (|) is nodal {*} - multi method flatmap(&block, :$label) { - self.map(&block, :$label).flat - } - - method !grep-k(Callable:D $test) { - Seq.new(class :: does Iterator { - has Mu $!iter; - has Mu $!test; - has int $!index; - method !SET-SELF(\list,Mu \test) { - $!iter = list.iterator; - $!test := test; - $!index = -1; - self - } - method new(\list,Mu \test) { nqp::create(self)!SET-SELF(list,test) } - method pull-one() is raw { - $!index = $!index + 1 - until ($_ := $!iter.pull-one) =:= IterationEnd || $!test($_); - $_ =:= IterationEnd - ?? IterationEnd - !! nqp::p6box_i($!index = $!index + 1) - } - method push-all($target --> IterationEnd) { - until ($_ := $!iter.pull-one) =:= IterationEnd { - $!index = $!index + 1; - $target.push(nqp::p6box_i($!index)) if $!test($_); - } - } - }.new(self, $test)) - } - method !grep-kv(Callable:D $test) { - Seq.new(class :: does Iterator { - has Mu $!iter; - has Mu $!test; - has int $!index; - has Mu $!value; - method !SET-SELF(\list,Mu \test) { - $!iter = list.iterator; - $!test := test; - $!index = -1; - self - } - method new(\list,Mu \test) { nqp::create(self)!SET-SELF(list,test) } - method pull-one() is raw { - if $!value.DEFINITE { - my \tmp = $!value; - $!value := nqp::null; - tmp - } - else { - $!index = $!index + 1 - until ($_ := $!iter.pull-one) =:= IterationEnd - || $!test($_); - if $_ =:= IterationEnd { - IterationEnd; - } - else { - $!value := $_; - nqp::p6box_i($!index = $!index + 1) - } - } - } - method push-all($target --> IterationEnd) { - nqp::until( - nqp::eqaddr(($_ := $!iter.pull-one),IterationEnd), - nqp::stmts( - $!index = nqp::add_i($!index,1); - nqp::if( - $!test($_), - nqp::stmts( # doesn't sink - $target.push(nqp::p6box_i($!index)); - $target.push($_); - ) - ) - ) - ); - } - }.new(self, $test)) - } - method !grep-p(Callable:D $test) { - Seq.new(class :: does Iterator { - has Mu $!iter; - has Mu $!test; - has int $!index; - method !SET-SELF(\list,Mu \test) { - $!iter = list.iterator; - $!test := test; - $!index = -1; - self - } - method new(\list,Mu \test) { nqp::create(self)!SET-SELF(list,test) } - method pull-one() is raw { - $!index = $!index + 1 - until ($_ := $!iter.pull-one) =:= IterationEnd || $!test($_); - $_ =:= IterationEnd - ?? IterationEnd - !! Pair.new($!index = $!index + 1,$_) - } - method push-all($target --> IterationEnd) { - until ($_ := $!iter.pull-one) =:= IterationEnd { - $!index = $!index + 1; - $target.push(Pair.new($!index,$_)) if $!test($_); - } - } - }.new(self, $test)) - } - - role Grepper does Iterator { - has Mu $!iter; - has Mu $!test; - method SET-SELF(\list,Mu \test) { - $!iter = list.iterator; - $!test := test; - self - } - method new(\list,Mu \test) { nqp::create(self).SET-SELF(list,test) } - method is-lazy() { $!iter.is-lazy } - } - method !grep-callable(Callable:D $test) { - nqp::if( - $test.count == 1, - sequential-map( - self.iterator, - { nqp::if($test($_),$_,Empty) }, - Any) - , - nqp::stmts( - (my role CheatArity { - has $!arity; - has $!count; - - method set-cheat($new-arity, $new-count --> Nil) { - $!arity = $new-arity; - $!count = $new-count; - } - - method arity(Code:D:) { $!arity } - method count(Code:D:) { $!count } - }), - (my &tester = -> |c { - #note "*cough* {c.perl} -> {$test(|c).perl}"; - next unless $test(|c); - c.list - } but CheatArity), - &tester.set-cheat($test.arity, $test.count), - self.map(&tester) - ) - ) - } - method !grep-accepts(Mu $test) { - Seq.new(class :: does Grepper { - method pull-one() is raw { - nqp::until( - nqp::eqaddr(($_ := $!iter.pull-one),IterationEnd) - || $!test.ACCEPTS($_), - nqp::null - ); - $_ - } - method push-all($target --> IterationEnd) { - nqp::until( - nqp::eqaddr(($_ := $!iter.pull-one),IterationEnd), - nqp::if( # doesn't sink - $!test.ACCEPTS($_), - $target.push($_) - ) - ); - } - }.new(self, $test)) - } - - method !first-result(\index,\value,$what,%a) is raw { - nqp::stmts( - (my $storage := nqp::getattr(%a,Map,'$!storage')), - nqp::if( - nqp::elems($storage), # some adverb - nqp::if( - nqp::iseq_i(nqp::elems($storage),1), # one adverb - nqp::if( - nqp::atkey($storage,"k"), # :k - nqp::p6box_i(index), - nqp::if( - nqp::atkey($storage,"p"), # :p - Pair.new(index,value), - nqp::if( - nqp::atkey($storage,"v"), # :v - value, - nqp::if( - nqp::atkey($storage,"kv"), # :kv - (index,value), - nqp::stmts( # no truthy or different - (my str $key = - nqp::iterkey_s(nqp::shift(nqp::iterator($storage)))), - nqp::if( - (nqp::iseq_s($key,"k") # :!k || :!p || :!kv - || nqp::iseq_s($key,"p") - || nqp::iseq_s($key,"kv")), - value, - nqp::if( - nqp::iseq_s($key,"v"), # :!v - Failure.new("Specified a negated :v adverb"), - Failure.new(X::Adverb.new( # :foo ?? - :$what, - :source(try { self.VAR.name } // self.WHAT.perl), - :unexpected(%a.keys))) - ) - ) - ) - ) - ) - ) - ), - Failure.new(X::Adverb.new( # multiple adverbs ?? - :$what, - :source(try { self.VAR.name } // self.WHAT.perl), - :nogo(%a.keys.grep: /k|v|p/) - :unexpected(%a.keys.grep: { !.match(/k|v|p/) } ))) - ), - value # no adverb - ) - ) - } - - proto method grep(|) is nodal {*} - multi method grep(Bool:D $t) { - X::Match::Bool.new( type => '.grep').throw - } - multi method grep(Mu $t) { - my $storage := nqp::getattr(%_,Map,'$!storage'); - if nqp::iseq_i(nqp::elems($storage),0) { - nqp::istype($t,Regex:D) - ?? self!grep-accepts: $t - !! nqp::istype($t,Callable:D) - ?? self!grep-callable: $t - !! self!grep-accepts: $t - } - elsif nqp::iseq_i(nqp::elems($storage),1) { - if nqp::atkey($storage,"k") { - nqp::istype($t,Regex:D) - ?? self!grep-k: { $t.ACCEPTS($_) } - !! nqp::istype($t,Callable:D) - ?? self!grep-k: $t - !! self!grep-k: { $t.ACCEPTS($_) } - } - elsif nqp::atkey($storage,"kv") { - nqp::istype($t,Regex:D) - ?? self!grep-kv: { $t.ACCEPTS($_) } - !! nqp::istype($t,Callable:D) - ?? self!grep-kv: $t - !! self!grep-kv: { $t.ACCEPTS($_) } - } - elsif nqp::atkey($storage,"p") { - nqp::istype($t,Regex:D) - ?? self!grep-p: { $t.ACCEPTS($_) } - !! nqp::istype($t,Callable:D) - ?? self!grep-p: $t - !! self!grep-p: { $t.ACCEPTS($_) } - } - elsif nqp::atkey($storage,"v") { - nqp::istype($t,Regex:D) - ?? self!grep-accepts: $t - !! nqp::istype($t,Callable:D) - ?? self!grep-callable: $t - !! self!grep-accepts: $t - } - else { - my str $key = - nqp::iterkey_s(nqp::shift(nqp::iterator($storage))); - if nqp::iseq_s($key,"k") || nqp::iseq_s($key,"kv") || nqp::iseq_s($key,"p") { - nqp::istype($t,Regex:D) - ?? self!grep-accepts: $t - !! nqp::istype($t,Callable:D) - ?? self!grep-callable: $t - !! self!grep-accepts: $t - } - else { - nqp::iseq_s($key,"k") - ?? die "Specified a negated :v adverb" - !! X::Adverb.new( - :what, - :source(try { self.VAR.name } // self.WHAT.perl), - :unexpected($key) - ).throw - } - } - } - else { - X::Adverb.new( - :what, - :source(try { self.VAR.name } // self.WHAT.perl), - :nogo(%_.keys.grep: /k|v|kv|p/) - :unexpected(%_.keys.grep: { !.match(/k|v|kv|p/) } ) - ).throw - } - } - - proto method first(|) is nodal {*} - multi method first(Bool:D $t) { - Failure.new(X::Match::Bool.new( type => '.first' )) - } - # need to handle Regex differently, since it is also Callable - multi method first(Regex:D $test, :$end, *%a) is raw { - $end - ?? self!first-accepts-end($test,%a) - !! self!first-accepts($test,%a) - } - multi method first(Callable:D $test, :$end, *%a is copy) is raw { - if $end { - nqp::stmts( - (my $elems = self.elems), - nqp::if( - ($elems && nqp::not_i($elems == Inf)), - nqp::stmts( - (my int $index = $elems), - nqp::while( - nqp::isge_i(($index = nqp::sub_i($index,1)),0), - nqp::if( - $test(self.AT-POS($index)), - return self!first-result( - $index,self.AT-POS($index),'first :end',%a) - ) - ), - Nil - ), - Nil - ) - ) - } - else { - nqp::stmts( - (my $iter := self.iterator), - (my int $index), - nqp::until( - (nqp::eqaddr(($_ := $iter.pull-one),IterationEnd) - || $test($_)), - ($index = nqp::add_i($index,1)) - ), - nqp::if( - nqp::eqaddr($_,IterationEnd), - Nil, - self!first-result($index,$_,'first',%a) - ) - ) - } - } - multi method first(Mu $test = True, :$end, *%a) is raw { - $end - ?? self!first-accepts-end($test,%a) - !! self!first-accepts($test,%a) - } - method !first-accepts(Mu $test,%a) is raw { - nqp::stmts( - (my $iter := self.iterator), - (my int $index), - nqp::until( - (nqp::eqaddr(($_ := $iter.pull-one),IterationEnd) - || $test.ACCEPTS($_)), - ($index = nqp::add_i($index,1)) - ), - nqp::if( - nqp::eqaddr($_,IterationEnd), - Nil, - self!first-result($index,$_,'first',%a) - ) - ) - } - method !first-accepts-end(Mu $test,%a) is raw { - nqp::stmts( - (my $elems = self.elems), - nqp::if( - ($elems && nqp::not_i($elems == Inf)), - nqp::stmts( - (my int $index = $elems), - nqp::while( - nqp::isge_i(($index = nqp::sub_i($index,1)),0), - nqp::if( - $test.ACCEPTS(self.AT-POS($index)), - return self!first-result( - $index,self.AT-POS($index),'first :end',%a) - ) - ), - Nil - ), - Nil - ) - ) - } - method !iterator-and-first($action,\first) is raw { - nqp::if( - self.is-lazy, - X::Cannot::Lazy.new(:$action).throw, - nqp::stmts( - (my $iterator := self.iterator), - nqp::until( - nqp::eqaddr((my $pulled := $iterator.pull-one),IterationEnd), - nqp::if( - nqp::isconcrete($pulled), - nqp::stmts( - (first = $pulled), - (return $iterator) - ) - ) - ), - Mu - ) - ) - } - - proto method min (|) is nodal {*} - multi method min() { - nqp::stmts( - nqp::if( - (my $iter := self!iterator-and-first(".min",my $min)), - nqp::until( - nqp::eqaddr((my $pulled := $iter.pull-one),IterationEnd), - nqp::if( - (nqp::isconcrete($pulled) && $pulled cmp $min < 0), - $min = $pulled - ) - ) - ), - nqp::if(nqp::defined($min),$min,Inf) - ) - } - multi method min(&by) { - nqp::stmts( - (my $cmp := nqp::if( - nqp::iseq_i(&by.arity,2),&by,{ &by($^a) cmp &by($^b) })), - nqp::if( - (my $iter := self!iterator-and-first(".min",my $min)), - nqp::until( - nqp::eqaddr((my $pulled := $iter.pull-one),IterationEnd), - nqp::if( - (nqp::isconcrete($pulled) && $cmp($pulled,$min) < 0), - $min = $pulled - ) - ) - ), - nqp::if(nqp::defined($min),$min,Inf) - ) - } - - proto method max (|) is nodal {*} - multi method max() { - nqp::stmts( - nqp::if( - (my $iter := self!iterator-and-first(".max",my $max)), - nqp::until( - nqp::eqaddr((my $pulled := $iter.pull-one),IterationEnd), - nqp::if( - (nqp::isconcrete($pulled) && $pulled cmp $max > 0), - $max = $pulled - ) - ) - ), - nqp::if(nqp::defined($max),$max,-Inf) - ) - } - multi method max(&by) { - nqp::stmts( - (my $cmp := nqp::if( - nqp::iseq_i(&by.arity,2),&by,{ &by($^a) cmp &by($^b) })), - nqp::if( - (my $iter := self!iterator-and-first(".max",my $max)), - nqp::until( - nqp::eqaddr((my $pulled := $iter.pull-one),IterationEnd), - nqp::if( - (nqp::isconcrete($pulled) && $cmp($pulled,$max) > 0), - $max = $pulled - ) - ) - ), - nqp::if(nqp::defined($max),$max,-Inf) - ) - } - - method !minmax-range-init(\value,\mi,\exmi,\ma,\exma --> Nil) { - mi = value.min; - exmi = value.excludes-min; - ma = value.max; - exma = value.excludes-max; - } - method !minmax-range-check(\value,\mi,\exmi,\ma,\exma --> Nil) { - nqp::stmts( - nqp::if( - ((value.min cmp mi) < 0), - nqp::stmts( - (mi = value.min), - (exmi = value.excludes-min) - ) - ), - nqp::if( - ((value.max cmp ma) > 0), - nqp::stmts( - (ma = value.max), - (exma = value.excludes-max) - ) - ) - ) - } - method !cmp-minmax-range-check(\value,$cmp,\mi,\exmi,\ma,\exma --> Nil) { - nqp::stmts( # $cmp sigillless confuses the optimizer - nqp::if( - ($cmp(value.min,mi) < 0), - nqp::stmts( - (mi = value.min), - (exmi = value.excludes-min) - ) - ), - nqp::if( - ($cmp(value.max,ma) > 0), - nqp::stmts( - (ma = value.max), - (exma = value.excludes-max) - ) - ) - ) - } - - proto method minmax (|) is nodal {*} - multi method minmax() { - nqp::stmts( - nqp::if( - (my $iter := self!iterator-and-first(".minmax",my $pulled)), - nqp::stmts( - nqp::if( - nqp::istype($pulled,Range), - self!minmax-range-init($pulled, - my $min,my int $excludes-min,my $max,my int $excludes-max), - nqp::if( - nqp::istype($pulled,Positional), - self!minmax-range-init($pulled.minmax, # recurse for min/max - $min,$excludes-min,$max,$excludes-max), - ($min = $max = $pulled) - ) - ), - nqp::until( - nqp::eqaddr(($pulled := $iter.pull-one),IterationEnd), - nqp::if( - nqp::isconcrete($pulled), - nqp::if( - nqp::istype($pulled,Range), - self!minmax-range-check($pulled, - $min,$excludes-min,$max,$excludes-max), - nqp::if( - nqp::istype($pulled,Positional), - self!minmax-range-check($pulled.minmax, - $min,$excludes-min,$max,$excludes-max), - nqp::if( - (($pulled cmp $min) < 0), - ($min = $pulled), - nqp::if( - (($pulled cmp $max) > 0), - ($max = $pulled) - ) - ) - ) - ) - ) - ) - ) - ), - nqp::if( - nqp::defined($min), - Range.new($min,$max,:$excludes-min,:$excludes-max), - Range.new(Inf,-Inf) - ) - ) - } - multi method minmax(&by) { - nqp::stmts( - nqp::if( - (my $iter := self!iterator-and-first(".minmax",my $pulled)), - nqp::stmts( - (my $cmp = nqp::if( - nqp::iseq_i(&by.arity,2),&by,{ &by($^a) cmp &by($^b) }) - ), - nqp::if( - nqp::istype($pulled,Range), - self!minmax-range-init($pulled, - my $min,my int $excludes-min,my $max,my int $excludes-max), - nqp::if( - nqp::istype($pulled,Positional), - self!minmax-range-init($pulled.minmax(&by), # recurse min/max - $min,$excludes-min,$max,$excludes-max), - ($min = $max = $pulled) - ) - ), - nqp::until( - nqp::eqaddr(($pulled := $iter.pull-one),IterationEnd), - nqp::if( - nqp::isconcrete($pulled), - nqp::if( - nqp::istype($pulled,Range), - self!cmp-minmax-range-check($pulled, - $cmp,$min,$excludes-min,$max,$excludes-max), - nqp::if( - nqp::istype($pulled,Positional), - self!cmp-minmax-range-check($pulled.minmax(&by), - $cmp,$min,$excludes-min,$max,$excludes-max), - nqp::if( - ($cmp($pulled,$min) < 0), - ($min = $pulled), - nqp::if( - ($cmp($pulled,$max) > 0), - ($max = $pulled) - ) - ) - ) - ) - ) - ) - ) - ), - nqp::if( - nqp::defined($min), - Range.new($min,$max,:$excludes-min,:$excludes-max), - Range.new(Inf,-Inf) - ) - ) - } - - proto method sort(|) is nodal {*} - multi method sort() { - nqp::if( - nqp::eqaddr( - self.iterator.push-until-lazy(my $list := IterationBuffer.new), - IterationEnd - ), - Seq.new( - Rakudo::Iterator.ReifiedList( - Rakudo::Sorting.MERGESORT-REIFIED-LIST( - nqp::p6bindattrinvres(nqp::create(List),List,'$!reified',$list) - ) - ) - ), - X::Cannot::Lazy.new(:action).throw - ) - } - multi method sort(&by) { - nqp::stmts( - nqp::unless( - nqp::eqaddr( - self.iterator.push-until-lazy(my $list := IterationBuffer.new), - IterationEnd - ), - X::Cannot::Lazy.new(:action).throw - ), - Seq.new( - Rakudo::Iterator.ReifiedList( - nqp::if( - nqp::eqaddr(&by,&infix:), - Rakudo::Sorting.MERGESORT-REIFIED-LIST( - nqp::p6bindattrinvres( - nqp::create(List),List,'$!reified',$list) - ), - nqp::if( - &by.count < 2, - Rakudo::Sorting.MERGESORT-REIFIED-LIST-AS( - nqp::p6bindattrinvres( - nqp::create(List),List,'$!reified',$list), - &by - ), - Rakudo::Sorting.MERGESORT-REIFIED-LIST-WITH( - nqp::p6bindattrinvres( - nqp::create(List),List,'$!reified',$list), - &by - ) - ) - ) - ) - ) - ) - } - - method collate { - self.sort(&[coll]); - } - sub find-reducer-for-op(&op) { - nqp::if( - nqp::iseq_s(&op.prec("prec"),"f="), - &METAOP_REDUCE_LISTINFIX, - nqp::if( - nqp::iseq_i(nqp::chars(my str $assoc = &op.prec("assoc")),0), - &METAOP_REDUCE_LEFT, - ::(nqp::concat('&METAOP_REDUCE_',nqp::uc($assoc))) - ) - ) - } - - proto method reduce(|) {*} - multi method reduce(&with) is nodal { - return unless self.DEFINITE; - my $reducer := find-reducer-for-op(&with); - $reducer(&with)(self) if $reducer; - } - - proto method produce(|) {*} - multi method produce(&with) is nodal { - return unless self.DEFINITE; - my $reducer := find-reducer-for-op(&with); - $reducer(&with,1)(self) if $reducer; - } - - proto method unique(|) is nodal {*} - multi method unique() { - Seq.new(class :: does Iterator { - has $!iter; - has $!seen; - method !SET-SELF(\list) { - nqp::stmts( - ($!iter := list.iterator), - ($!seen := nqp::hash), - self - ) - } - method new(\list) { nqp::create(self)!SET-SELF(list) } - method pull-one() is raw { - nqp::stmts( - nqp::until( - nqp::eqaddr((my $pulled := $!iter.pull-one),IterationEnd) - || (nqp::not_i(nqp::existskey( - $!seen, - (my $needle := $pulled.WHICH) - )) && nqp::bindkey($!seen,$needle,1)), - nqp::null - ), - $pulled - ) - } - method push-all($target --> IterationEnd) { - nqp::until( - nqp::eqaddr((my $pulled := $!iter.pull-one),IterationEnd), - nqp::unless( - nqp::existskey($!seen,(my $needle := $pulled.WHICH)), - nqp::stmts( - nqp::bindkey($!seen,$needle,1), - $target.push($pulled) - ) - ) - ) - } - method is-lazy() { $!iter.is-lazy } - method sink-all(--> IterationEnd) { $!iter.sink-all } - }.new(self)) - } - multi method unique( :&as!, :&with! ) { - nqp::if( - nqp::eqaddr(&with,&[===]), # use optimized version - self.unique(:&as), - Seq.new( - Rakudo::Iterator.UniqueRepeatedAsWith(self.iterator,&as,&with,1) - ) - ) - } - multi method unique( :&as! ) { - Seq.new(class :: does Iterator { - has Mu $!iter; - has &!as; - has $!seen; - method !SET-SELF(\list, &!as) { - $!iter = list.iterator; - $!seen := nqp::hash(); - self - } - method new(\list, &as) { nqp::create(self)!SET-SELF(list, &as) } - method pull-one() is raw { - nqp::stmts( - nqp::until( - nqp::eqaddr((my $value := $!iter.pull-one),IterationEnd), - nqp::unless( - nqp::existskey($!seen,my $needle := &!as($value).WHICH), - nqp::stmts( - nqp::bindkey($!seen,$needle,1), - return-rw $value - ) - ) - ), - IterationEnd - ) - } - method push-all($target --> IterationEnd) { - nqp::until( - nqp::eqaddr((my $value := $!iter.pull-one),IterationEnd), - nqp::unless( - nqp::existskey($!seen,my $needle := &!as($value).WHICH), - nqp::stmts( # doesn't sink - nqp::bindkey($!seen,$needle,1), - $target.push($value) - ) - ) - ) - } - }.new(self, &as)) - } - multi method unique( :&with! ) { - nqp::if( - nqp::eqaddr(&with,&[===]), # use optimized version - self.unique, - Seq.new(Rakudo::Iterator.UniqueRepeatedWith(self.iterator,&with,1)) - ) - } - - proto method repeated(|) is nodal {*} - multi method repeated() { - Seq.new(class :: does Iterator { - has Mu $!iter; - has $!seen; - method !SET-SELF(\list) { - $!iter = list.iterator; - $!seen := nqp::hash(); - self - } - method new(\list) { nqp::create(self)!SET-SELF(list) } - method pull-one() is raw { - my Mu $value; - my str $needle; - nqp::until( - nqp::eqaddr(($value := $!iter.pull-one),IterationEnd), - nqp::existskey($!seen,$needle = nqp::unbox_s($value.WHICH)) - ?? return-rw $value - !! nqp::bindkey($!seen, $needle, 1) - ); - IterationEnd - } - method push-all($target --> IterationEnd) { - my Mu $value; - my str $needle; - nqp::until( # doesn't sink - nqp::eqaddr(($value := $!iter.pull-one),IterationEnd), - nqp::existskey($!seen,$needle = nqp::unbox_s($value.WHICH)) - ?? $target.push($value) - !! nqp::bindkey($!seen, $needle, 1) - ); - } - method is-lazy() { $!iter.is-lazy } - }.new(self)) - } - multi method repeated( :&as!, :&with! ) { - nqp::if( - nqp::eqaddr(&with,&[===]), # use optimized version - self.repeated(:&as), - Seq.new( - Rakudo::Iterator.UniqueRepeatedAsWith(self.iterator,&as,&with,0) - ) - ) - } - multi method repeated( :&as! ) { - Seq.new(class :: does Iterator { - has Mu $!iter; - has &!as; - has $!seen; - method !SET-SELF(\list, &!as) { - $!iter = list.iterator; - $!seen := nqp::hash(); - self - } - method new(\list, &as) { nqp::create(self)!SET-SELF(list, &as) } - method pull-one() is raw { - my Mu $value; - my str $needle; - nqp::until( - nqp::eqaddr(($value := $!iter.pull-one),IterationEnd), - nqp::existskey($!seen,$needle = nqp::unbox_s(&!as($value).WHICH)) - ?? return-rw $value - !! nqp::bindkey($!seen, $needle, 1) - ); - IterationEnd - } - method push-all($target --> IterationEnd) { - my Mu $value; - my str $needle; - nqp::until( # doesn't sink - nqp::eqaddr(($value := $!iter.pull-one),IterationEnd), - nqp::existskey($!seen,$needle = nqp::unbox_s(&!as($value).WHICH)) - ?? $target.push($value) - !! nqp::bindkey($!seen, $needle, 1) - ); - } - method is-lazy() { $!iter.is-lazy } - }.new(self, &as)) - } - multi method repeated( :&with! ) { - nqp::if( - nqp::eqaddr(&with,&[===]), # use optimized version - self.repeated, - Seq.new(Rakudo::Iterator.UniqueRepeatedWith(self.iterator,&with,0)) - ) - } - - proto method squish(|) is nodal {*} - multi method squish( :&as!, :&with = &[===] ) { - Seq.new(class :: does Iterator { - has Mu $!iter; - has &!as; - has &!with; - has $!last_as; - has int $!first; - method !SET-SELF(\list, &!as, &!with) { - $!iter = list.iterator; - $!first = 1; - self - } - method new(\list, &as, &with) { - nqp::create(self)!SET-SELF(list, &as, &with) - } - method pull-one() is raw { - my Mu $value := $!iter.pull-one; - unless nqp::eqaddr($value,IterationEnd) { - my $which := &!as($value); - if $!first { - $!first = 0; - } - else { - until !with($!last_as, $which) or ($value := $!iter.pull-one) =:= IterationEnd { - $!last_as = $which; - $which := &!as($value); - } - } - $!last_as = $which; - } - $value; - } - method push-all($target --> IterationEnd) { - my Mu $value := $!iter.pull-one; - unless nqp::eqaddr($value,IterationEnd) { - my $which; - my $last_as := $!last_as; - nqp::if( - $!first, - nqp::stmts( # doesn't sink - ($target.push($value)), - ($which := &!as($value)), - ($last_as := $which), - ($value := $!iter.pull-one) - ) - ); - nqp::until( - nqp::eqaddr($value,IterationEnd), - nqp::stmts( - nqp::unless( # doesn't sink - with($last_as,$which := &!as($value)), - $target.push($value) - ), - ($last_as := $which), - ($value := $!iter.pull-one) - ) - ); - } - } - method is-lazy() { $!iter.is-lazy } - }.new(self, &as, &with)) - } - multi method squish( :&with = &[===] ) { - Seq.new(class :: does Iterator { - has Mu $!iter; - has &!with; - has Mu $!last; - has int $!first; - method !SET-SELF(\list, &!with) { - $!iter = list.iterator; - $!first = 1; - self - } - method new(\list, &with) { nqp::create(self)!SET-SELF(list, &with) } - method pull-one() is raw { - my Mu $value := $!iter.pull-one; - unless nqp::eqaddr($value,IterationEnd) { - if $!first { - $!first = 0; - } - else { - my $ov = $value; - until !with($!last, $value) - or ($value := $!iter.pull-one) =:= IterationEnd { - $!last = $ov; - $ov = $value; - } - } - $!last = $value - } - $value; - } - method push-all($target --> IterationEnd) { - my Mu $value := $!iter.pull-one; - unless nqp::eqaddr($value,IterationEnd) { - my $last_val = $!last; - nqp::if( - $!first, - nqp::stmts( # doesn't sink - ($target.push($value)), - ($last_val := $value), - ($value := $!iter.pull-one) - ) - ); - nqp::until( - nqp::eqaddr($value,IterationEnd), - nqp::stmts( - nqp::unless( # doesn't sink - with($last_val, $value), - $target.push($value) - ), - ($last_val := $value), - ($value := $!iter.pull-one) - ) - ); - } - } - method is-lazy() { $!iter.is-lazy } - }.new(self, &with)) - } - - proto method pairup(|) is nodal {*} - multi method pairup(Any:U:) { () } - multi method pairup(Any:D:) { - my \iter := self.iterator; - gather { - nqp::until( - nqp::eqaddr((my $pulled := iter.pull-one),IterationEnd), - nqp::if( - nqp::istype($pulled,Pair), - (take nqp::p6bindattrinvres( - nqp::clone($pulled), - Pair, - '$!value', - nqp::clone(nqp::decont(nqp::getattr($pulled,Pair,'$!value'))) - )), - nqp::if( - nqp::istype($pulled,Map) && nqp::not_i(nqp::iscont($pulled)), - (take Slip.from-iterator($pulled.iterator)), - nqp::if( - nqp::eqaddr((my $value := iter.pull-one),IterationEnd), - X::Pairup::OddNumber.new.throw, - take Pair.new($pulled,$value) - ) - ) - ) - ) - } - } - - proto method toggle(|) {*} - multi method toggle(Any:D: Callable:D \condition, :$off!) { - Seq.new( $off - ?? Rakudo::Iterator.Until(self.iterator, condition) - !! Rakudo::Iterator.While(self.iterator, condition) - ) - } - multi method toggle(Any:D: Callable:D \condition) { - Seq.new(Rakudo::Iterator.While(self.iterator, condition)) - } - multi method toggle(Any:D: *@conditions, :$off) { - Seq.new( - Rakudo::Iterator.Toggle(self.iterator, @conditions.iterator, !$off) - ) - } - - proto method head(|) {*} - multi method head(Any:D:) is raw { - nqp::if( - nqp::eqaddr((my $pulled := self.iterator.pull-one),IterationEnd), - Nil, - $pulled - ) - } - multi method head(Any:D: Callable:D $w) { - Seq.new( - Rakudo::Iterator.AllButLastNValues(self.iterator,-($w(0).Int)) - ) - } - multi method head(Any:D: $n) { - Seq.new(Rakudo::Iterator.NextNValues(self.iterator,$n)) - } - - proto method tail(|) {*} - multi method tail() is raw { - nqp::if( - nqp::eqaddr((my $pulled := - Rakudo::Iterator.LastValue(self.iterator,'tail')), - IterationEnd - ), - Nil, - $pulled - ) - } - multi method tail($n) { - Seq.new( - nqp::if( - nqp::istype($n,Callable), - nqp::stmts( - (my $iterator := self.iterator), - nqp::if( - nqp::isgt_i((my $skip := -($n(0).Int)),0), - nqp::if( - $iterator.skip-at-least($skip), - $iterator, - Rakudo::Iterator.Empty), - $iterator)), - Rakudo::Iterator.LastNValues(self.iterator,$n,'tail') - ) - ) - } - - proto method skip(|) {*} - multi method skip() { - my $iter := self.iterator; - Seq.new( $iter.skip-one ?? $iter !! Rakudo::Iterator.Empty ) - } - multi method skip(Whatever) { Seq.new(Rakudo::Iterator.Empty) } - multi method skip(Callable:D $w) { - nqp::if( - nqp::isgt_i((my $tail := -($w(0).Int)),0), - self.tail($tail), - Seq.new(Rakudo::Iterator.Empty) - ) - } - multi method skip(Int() $n) { - my $iter := self.iterator; - Seq.new( $iter.skip-at-least($n) ?? $iter !! Rakudo::Iterator.Empty ) - } - - proto method minpairs(|) {*} - multi method minpairs(Any:D:) { - my @found; - for self.pairs { - my $value := .value; - state $min = $value; - nqp::if( - nqp::iseq_i( (my $cmp := $value cmp $min), -1 ), - nqp::stmts((@found = $_), ($min = $value)), - nqp::if( - nqp::iseq_i($cmp, 0), - @found.push($_) - ) - ) - } - Seq.new(@found.iterator) - } - - proto method maxpairs(|) {*} - multi method maxpairs(Any:D:) { - my @found; - for self.pairs { - my $value := .value; - state $max = $value; - nqp::if( - nqp::iseq_i( (my $cmp := $value cmp $max), 1 ), - nqp::stmts((@found = $_), ($max = $value)), - nqp::if( - nqp::iseq_i($cmp, 0), - @found.push($_) - ) - ) - } - Seq.new(@found.iterator) - } - - proto method batch(|) is nodal {*} - multi method batch(Any:D: Int:D :$elems!) { - Seq.new(Rakudo::Iterator.Batch(self.iterator,$elems,1)) - } - multi method batch(Any:D: Int:D $batch) { - Seq.new(Rakudo::Iterator.Batch(self.iterator,$batch,1)) - } - - proto method rotor(|) is nodal {*} - multi method rotor(Any:D: Int:D $batch, :$partial) { - Seq.new(Rakudo::Iterator.Batch(self.iterator,$batch,$partial)) - } - multi method rotor(Any:D: *@cycle, :$partial) { - Seq.new(Rakudo::Iterator.Rotor(self.iterator,@cycle,$partial)) - } -} - -BEGIN Attribute.^compose; - -proto sub infix:(|) is pure {*} -multi sub infix:(Mu:D \a, Mu:U) { a } -multi sub infix:(Mu:U, Mu:D \b) { b } -multi sub infix:(Mu:D \a, Mu:D \b) { (a cmp b) < 0 ?? a !! b } -multi sub infix:(Int:D \a, Int:D \b) { nqp::if(nqp::islt_i(nqp::cmp_I(nqp::decont(a), nqp::decont(b)), 0), a, b) } -multi sub infix:(int \a, int \b) { nqp::if(nqp::islt_i(nqp::cmp_i(a, b), 0), a, b) } -multi sub infix:(Num:D \a, Num:D \b) { nqp::if(nqp::islt_i(nqp::cmp_n(a, b), 0), a, b) } -multi sub infix:(num \a, num \b) { nqp::if(nqp::islt_i(nqp::cmp_n(a, b), 0), a, b) } -multi sub infix:(+args is raw) { args.min } -sub min(+args, :&by = &infix:) { args.min(&by) } - -proto sub infix:(|) is pure {*} -multi sub infix:(Mu:D \a, Mu:U) { a } -multi sub infix:(Mu:U, Mu:D \b) { b } -multi sub infix:(Mu:D \a, Mu:D \b) { (a cmp b) > 0 ?? a !! b } -multi sub infix:(Int:D \a, Int:D \b) { nqp::if(nqp::isgt_i(nqp::cmp_I(nqp::decont(a), nqp::decont(b)), 0), a, b) } -multi sub infix:(int \a, int \b) { nqp::if(nqp::isgt_i(nqp::cmp_i(a, b), 0), a, b) } -multi sub infix:(Num:D \a, Num:D \b) { nqp::if(nqp::isgt_i(nqp::cmp_n(a, b), 0), a, b) } -multi sub infix:(num \a, num \b) { nqp::if(nqp::isgt_i(nqp::cmp_n(a, b), 0), a, b) } -multi sub infix:(+args) { args.max } -sub max(+args, :&by = &infix:) { args.max(&by) } - -proto sub infix:(|) is pure {*} -multi sub infix:(+args) { args.minmax } -sub minmax(+args, :&by = &infix:) { args.minmax(&by) } - -proto sub map(|) {*} -multi sub map(&code, +values) { my $laze = values.is-lazy; values.map(&code).lazy-if($laze) } - -proto sub grep(|) {*} -multi sub grep(Mu $test, +values, *%a) { - my $laze = values.is-lazy; - values.grep($test,|%a).lazy-if($laze) -} -multi sub grep(Bool:D $t, |) { X::Match::Bool.new(:type).throw } - -proto sub first(|) {*} -multi sub first(Bool:D $t, |) { Failure.new(X::Match::Bool.new(:type)) } -multi sub first(Mu $test, +values, *%a) { values.first($test,|%a) } - -proto sub join(|) {*} -multi sub join($sep = '', *@values) { @values.join($sep) } - -proto sub reduce (|) {*} -multi sub reduce (&with, +list) { list.reduce(&with) } - -proto sub produce (|) {*} -multi sub produce (&with, +list) { list.produce(&with) } - -proto sub unique(|) {*} -multi sub unique(+values, |c) { my $laze = values.is-lazy; values.unique(|c).lazy-if($laze) } - -proto sub squish(|) {*} -multi sub squish(+values, |c) { my $laze = values.is-lazy; values.squish(|c).lazy-if($laze) } - -proto sub repeated(|) {*} -multi sub repeated(+values, |c) { my $laze = values.is-lazy; values.repeated(|c).lazy-if($laze) } - -proto sub sort(|) {*} -multi sub sort(&by, @values) { @values.sort(&by) } -multi sub sort(&by, +values) { values.sort(&by) } -multi sub sort(@values) { @values.sort } -multi sub sort(+values) { values.sort } - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Any-iterable-methods.pm6 rakudo-2018.03/src/core/Any-iterable-methods.pm6 --- rakudo-2018.02.1/src/core/Any-iterable-methods.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Any-iterable-methods.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,2021 @@ +# Now that Iterable is defined, we add extra methods into Any for the list +# operations. (They can't go into Any right away since we need Attribute to +# define the various roles, and Attribute inherits from Any. We will do a +# re-compose of Attribute to make sure it gets the list methods at the end +# of this file. Note the general pattern for these list-y methods is that +# they check if they have an Iterable already, and if not obtain one to +# work on by doing a .list coercion. +use MONKEY-TYPING; +augment class Any { + + proto method map(|) is nodal {*} + multi method map(Hash \h) { + die "Cannot map a {self.^name} to a {h.^name}. +Did you mean to add a stub (\{...\}) or did you mean to .classify?" + } + + multi method map(\SELF: █; :$label, :$item) { + sequential-map(($item ?? (SELF,) !! SELF).iterator, &block, $label); + } + + my class IterateOneWithPhasers does SlippyIterator { + has &!block; + has $!source; + has $!label; + has Int $!NEXT; # SHOULD BE int, but has Int performs better + has Int $!did-init; # SHOULD BE int, but has Int performs better + has Int $!did-iterate; # SHOULD BE int, but has Int performs better + + method !SET-SELF(\block,\source,\label) { + nqp::stmts( + (&!block := block), + ($!source := source), + ($!label := label), + ($!NEXT = block.has-phaser('NEXT')), + self + ) + } + method new(\bl,\sou,\la) { nqp::create(self)!SET-SELF(bl,sou,la) } + + method is-lazy() { $!source.is-lazy } + + method pull-one() is raw { + my int $stopped; + my $value; + my $result; + + nqp::unless( + $!did-init, + nqp::stmts( + ($!did-init = 1), + nqp::if( + &!block.has-phaser('FIRST'), + nqp::p6setfirstflag(&!block) + ) + ) + ); + + if $!slipping && nqp::not_i(nqp::eqaddr(($result := self.slip-one),IterationEnd)) { + # $result will be returned at the end + } + elsif nqp::eqaddr(($value := $!source.pull-one),IterationEnd) { + $result := IterationEnd + } + else { + nqp::until( + $stopped, + nqp::handle( + nqp::stmts( + ($stopped = 1), + ($result := &!block($value)), + ($!did-iterate = 1), + nqp::if( + nqp::istype($result, Slip), + nqp::if( + nqp::eqaddr(($result := self.start-slip($result)), IterationEnd), + nqp::if( + nqp::not_i(nqp::eqaddr(($value := $!source.pull-one),IterationEnd)), + ($stopped = 0) + ), + ) + ), + nqp::if($!NEXT, &!block.fire_phasers('NEXT')), + ), + 'LABELED', $!label, + 'NEXT', nqp::stmts( + ($!did-iterate = 1), + nqp::if($!NEXT, &!block.fire_phasers('NEXT')), + nqp::eqaddr(($value := $!source.pull-one), IterationEnd) + ?? ($result := IterationEnd) + !! ($stopped = 0) + ), + 'REDO', ($stopped = 0), + 'LAST', nqp::stmts( + ($!did-iterate = 1), + ($result := IterationEnd) + ) + ), + :nohandler + ) + } + nqp::if( + $!did-iterate && nqp::eqaddr($result,IterationEnd), + &!block.fire_if_phasers('LAST') + ); + $result + } + + method push-all($target --> IterationEnd) { + nqp::unless( + $!did-init, + nqp::stmts( + ($!did-init = 1), + nqp::if( + &!block.has-phaser('FIRST'), + nqp::p6setfirstflag(&!block) + ) + ) + ); + + my int $stopped; + my int $done; + my $pulled; + my $value; + + nqp::if( + $!slipping, + nqp::until( + nqp::eqaddr(($value := self.slip-one),IterationEnd), + $target.push($value) + ) + ); + + until $done + || nqp::eqaddr(($value := $!source.pull-one),IterationEnd) { + nqp::stmts( + ($stopped = 0), + nqp::until( + $stopped, + nqp::stmts( + ($stopped = 1), + nqp::handle( + nqp::stmts( # doesn't sink + ($pulled := &!block($value)), + ($!did-iterate = 1), + nqp::if($!NEXT, &!block.fire_phasers('NEXT')), + nqp::if( + nqp::istype($pulled,Slip), + self.slip-all($pulled,$target), + $target.push($pulled) + ) + ), + 'LABELED', $!label, + 'NEXT', nqp::stmts( + ($!did-iterate = 1), + nqp::if($!NEXT, &!block.fire_phasers('NEXT')), + nqp::eqaddr( + ($value := $!source.pull-one), + IterationEnd + ) + ?? ($done = 1) + !! ($stopped = 0)), + 'REDO', ($stopped = 0), + 'LAST', ($done = $!did-iterate = 1) + ) + ), + :nohandler + ) + ) + } + nqp::if($!did-iterate,&!block.fire_if_phasers('LAST')) + } + + method sink-all(--> IterationEnd) { + nqp::unless( + $!did-init, + nqp::stmts( + ($!did-init = 1), + nqp::if( + &!block.has-phaser('FIRST'), + nqp::p6setfirstflag(&!block) + ) + ) + ); + + nqp::if( + $!slipping, + nqp::until( + nqp::eqaddr(self.slip-one,IterationEnd), + nqp::null + ) + ); + + my int $stopped; + my int $done; + my $value; + until $done + || nqp::eqaddr(($value := $!source.pull-one()),IterationEnd) { + nqp::stmts( + ($stopped = 0), + nqp::until( + $stopped, + nqp::stmts( + ($stopped = 1), + nqp::handle( + nqp::stmts( # doesn't sink + (&!block($value)), + ($!did-iterate = 1), + nqp::if($!NEXT, &!block.fire_phasers('NEXT')), + ), + 'LABELED', $!label, + 'NEXT', nqp::stmts( + ($!did-iterate = 1), + nqp::if($!NEXT, &!block.fire_phasers('NEXT')), + nqp::eqaddr( + ($value := $!source.pull-one), + IterationEnd + ) + ?? ($done = 1) + !! ($stopped = 0)), + 'REDO', ($stopped = 0), + 'LAST', ($done = $!did-iterate = 1) + ) + ), + :nohandler + ) + ) + } + nqp::if($!did-iterate,&!block.fire_if_phasers('LAST')) + } + } + + my class IterateOneNotSlippingWithoutPhasers does Iterator { + has &!block; + has $!source; + has $!label; + + method new(&block,$source,$label) { + my $iter := nqp::create(self); + nqp::bindattr($iter, self, '&!block', &block); + nqp::bindattr($iter, self, '$!source', $source); + nqp::bindattr($iter, self, '$!label', nqp::decont($label)); + $iter + } + + method is-lazy() { $!source.is-lazy } + + method pull-one() is raw { + if nqp::eqaddr((my $pulled := $!source.pull-one),IterationEnd) { + IterationEnd + } + else { + my $result; + my int $stopped; + nqp::stmts( + nqp::until( + $stopped, + nqp::stmts( + ($stopped = 1), + nqp::handle( + ($result := &!block($pulled)), + 'LABELED', $!label, + 'NEXT', nqp::if( + nqp::eqaddr( + ($pulled := $!source.pull-one), + IterationEnd + ), + ($result := IterationEnd), + ($stopped = 0) + ), + 'REDO', ($stopped = 0), + 'LAST', ($result := IterationEnd) + ), + ), + :nohandler + ), + $result + ) + } + } + + method push-all($target --> IterationEnd) { + my $pulled; + my int $stopped; + nqp::until( + nqp::eqaddr(($pulled := $!source.pull-one),IterationEnd), + nqp::stmts( + ($stopped = 0), + nqp::until( + $stopped, + nqp::stmts( + ($stopped = 1), + nqp::handle( + $target.push(&!block($pulled)), + 'LABELED', $!label, + 'REDO', ($stopped = 0), + 'NEXT', nqp::null, # need NEXT for next LABEL support + 'LAST', return + ) + ), + :nohandler + ) + ) + ) + } + + method sink-all(--> IterationEnd) { + my $pulled; + my int $stopped; + nqp::until( + nqp::eqaddr(($pulled := $!source.pull-one),IterationEnd), + nqp::stmts( + ($stopped = 0), + nqp::until( + $stopped, + nqp::stmts( + ($stopped = 1), + nqp::handle( + &!block($pulled), + 'LABELED', $!label, + 'REDO', ($stopped = 0), + 'NEXT', nqp::null, # need NEXT for next LABEL support + 'LAST', return + ) + ), + :nohandler + ) + ) + ) + } + } + + my class IterateOneWithoutPhasers does SlippyIterator { + has &!block; + has $!source; + has $!label; + + method new(&block,$source,$label) { + my $iter := nqp::create(self); + nqp::bindattr($iter, self, '&!block', &block); + nqp::bindattr($iter, self, '$!source', $source); + nqp::bindattr($iter, self, '$!label', nqp::decont($label)); + $iter + } + + method is-lazy() { $!source.is-lazy } + + method pull-one() is raw { + my int $redo = 1; + my $value; + my $result; + + if $!slipping && nqp::not_i(nqp::eqaddr( + ($result := self.slip-one), + IterationEnd + )) { + # $result will be returned at the end + } + elsif nqp::eqaddr( + ($value := $!source.pull-one), + IterationEnd + ) { + $result := $value + } + else { + nqp::while( + $redo, + nqp::stmts( + $redo = 0, + nqp::handle( + nqp::if( + nqp::istype(($result := &!block($value)),Slip), + nqp::if( + nqp::eqaddr( + ($result := self.start-slip($result)), IterationEnd), + nqp::if( + nqp::not_i(nqp::eqaddr( + ($value := $!source.pull-one), + IterationEnd + )), + $redo = 1 + ) + ) + ), + 'LABELED', + $!label, + 'NEXT', + nqp::if( + nqp::eqaddr( + ($value := $!source.pull-one),IterationEnd + ), + ($result := IterationEnd), + ($redo = 1) + ), + 'REDO', + ($redo = 1), + 'LAST', + ($result := IterationEnd) + ), + ), + :nohandler); + } + $result + } + + method push-all($target --> IterationEnd) { + nqp::stmts( + (my $value), + nqp::if( + $!slipping, + nqp::until( + nqp::eqaddr(($value := self.slip-one),IterationEnd), + $target.push($value) + ) + ), + nqp::until( + nqp::eqaddr(($value := $!source.pull-one),IterationEnd), + nqp::stmts( + (my int $redo = 1), + nqp::while( + $redo, + nqp::stmts( + ($redo = 0), + nqp::handle( + nqp::if( + nqp::istype((my $result := &!block($value)),Slip), + self.slip-all($result,$target), + $target.push($result) + ), + 'LABELED', $!label, + 'REDO', ($redo = 1), + 'LAST', return, + 'NEXT', nqp::null, # need NEXT for next LABEL support + ) + ), + :nohandler + ) + ) + ) + ) + } + + method sink-all(--> IterationEnd) { + nqp::stmts( + nqp::if( + $!slipping, + nqp::until( + nqp::eqaddr(self.slip-one,IterationEnd), + nqp::null + ) + ), + nqp::until( + nqp::eqaddr((my $value := $!source.pull-one()),IterationEnd), + nqp::stmts( + (my int $redo = 1), + nqp::while( + $redo, + nqp::stmts( + ($redo = 0), + nqp::handle( # doesn't sink + &!block($value), + 'LABELED', $!label, + 'NEXT', nqp::null, # need NEXT for next LABEL support + 'REDO', ($redo = 1), + 'LAST', return + ), + :nohandler + ) + ) + ) + ) + ) + } + } + + my class IterateTwoWithoutPhasers does SlippyIterator { + has &!block; + has $!source; + has $!label; + + method new(&block,$source,$label) { + my $iter := nqp::create(self); + nqp::bindattr($iter, self, '&!block', &block); + nqp::bindattr($iter, self, '$!source', $source); + nqp::bindattr($iter, self, '$!label', nqp::decont($label)); + $iter + } + + method is-lazy() { $!source.is-lazy } + + method pull-one() is raw { + my int $redo = 1; + my $value; + my $value2; + my $result; + + if $!slipping && nqp::not_i(nqp::eqaddr( + ($result := self.slip-one), + IterationEnd + )) { + # $result will be returned at the end + } + elsif nqp::eqaddr( + ($value := $!source.pull-one), + IterationEnd + ) { + $result := IterationEnd; + } + else { + nqp::while( + $redo, + nqp::stmts( + $redo = 0, + nqp::handle( + nqp::stmts( + nqp::if( + nqp::eqaddr(($value2 := $!source.pull-one),IterationEnd), + nqp::if( # don't have 2 params + nqp::istype(($result := &!block($value)),Slip), + ($result := self.start-slip($result)) # don't care if empty + ), + nqp::if( + nqp::istype(($result := &!block($value,$value2)),Slip), + nqp::if( + nqp::eqaddr(($result := self.start-slip($result)),IterationEnd), + nqp::unless( + nqp::eqaddr(($value := $!source.pull-one),IterationEnd), + ($redo = 1) + ) + ) + ) + ) + ), + 'LABELED', + $!label, + 'NEXT', + nqp::if( + nqp::eqaddr( + ($value := $!source.pull-one),IterationEnd + ), + ($result := IterationEnd), + ($redo = 1) + ), + 'REDO', + ($redo = 1), + 'LAST', + ($result := IterationEnd) + ), + ), + :nohandler); + } + $result + } + + method push-all($target --> IterationEnd) { + nqp::stmts( + (my $value), + nqp::if( + $!slipping, + nqp::until( + nqp::eqaddr(($value := self.slip-one),IterationEnd), + $target.push($value) + ) + ), + nqp::until( + nqp::eqaddr(($value := $!source.pull-one),IterationEnd), + nqp::stmts( + (my int $redo = 1), + nqp::while( + $redo, + nqp::stmts( + ($redo = 0), + nqp::handle( + nqp::if( + nqp::eqaddr( + (my $value2 := $!source.pull-one), + IterationEnd + ), + nqp::stmts( + (my $result := &!block($value)), + nqp::if( + nqp::istype($result,Slip), + self.slip-all($result,$target), + $target.push($result) + ), + return + ), + nqp::if( + nqp::istype( + ($result := &!block($value,$value2)), + Slip + ), + self.slip-all($result,$target), + $target.push($result) + ) + ), + 'LABELED', $!label, + 'REDO', ($redo = 1), + 'LAST', return, + 'NEXT', nqp::null, # need NEXT for next LABEL support + ) + ), + :nohandler + ) + ) + ) + ) + } + + method sink-all(--> IterationEnd) { + nqp::stmts( + nqp::if( + $!slipping, + nqp::until( + nqp::eqaddr(self.slip-one,IterationEnd), + nqp::null, + ) + ), + nqp::until( + nqp::eqaddr((my $value := $!source.pull-one()),IterationEnd), + nqp::stmts( + (my int $redo = 1), + nqp::while( + $redo, + nqp::stmts( + ($redo = 0), + nqp::handle( # doesn't sink + nqp::if( + nqp::eqaddr( + (my $value2 := $!source.pull-one), + IterationEnd + ), + nqp::stmts( + (&!block($value)), + return + ), + (&!block($value,$value2)) + ), + 'LABELED', $!label, + 'NEXT', nqp::null, # need NEXT for next LABEL support + 'REDO', ($redo = 1), + 'LAST', return + ) + ), + :nohandler + ) + ) + ) + ) + } + } + + my class IterateMoreWithPhasers does SlippyIterator { + has &!block; + has $!source; + has $!count; + has $!label; + has $!value-buffer; + has $!did-init; + has $!did-iterate; + has $!NEXT; + has $!CAN_FIRE_PHASERS; + + method new(&block, $source, $count, $label) { + my $iter := nqp::create(self); + nqp::bindattr($iter, self, '&!block', &block); + nqp::bindattr($iter, self, '$!source', $source); + nqp::bindattr($iter, self, '$!count', $count); + nqp::bindattr($iter, self, '$!label', nqp::decont($label)); + $iter + } + + method is-lazy() { $!source.is-lazy } + + method pull-one() is raw { + $!value-buffer.DEFINITE + ?? nqp::setelems($!value-buffer, 0) + !! ($!value-buffer := IterationBuffer.new); + my int $redo = 1; + my $result; + + if !$!did-init && nqp::can(&!block, 'fire_phasers') { + $!did-init = 1; + $!CAN_FIRE_PHASERS = 1; + $!NEXT = &!block.has-phaser('NEXT'); + nqp::p6setfirstflag(&!block) + if &!block.has-phaser('FIRST'); + } + + if $!slipping && !(($result := self.slip-one()) =:= IterationEnd) { + # $result will be returned at the end + } + elsif $!source.push-exactly($!value-buffer, $!count) =:= IterationEnd + && nqp::elems($!value-buffer) == 0 { + $result := IterationEnd + } + else { + nqp::while( + $redo, + nqp::stmts( + $redo = 0, + nqp::handle( + nqp::stmts( + ($result := nqp::p6invokeflat(&!block, $!value-buffer)), + ($!did-iterate = 1), + nqp::if( + nqp::istype($result, Slip), + nqp::stmts( + ($result := self.start-slip($result)), + nqp::if( + nqp::eqaddr($result, IterationEnd), + nqp::stmts( + (nqp::setelems($!value-buffer, 0)), + ($redo = 1 + unless nqp::eqaddr( + $!source.push-exactly($!value-buffer, $!count), + IterationEnd) + && nqp::elems($!value-buffer) == 0) + ) + ) + ) + ), + nqp::if($!NEXT, &!block.fire_phasers('NEXT')), + ), + 'LABELED', $!label, + 'NEXT', nqp::stmts( + ($!did-iterate = 1), + nqp::if($!NEXT, &!block.fire_phasers('NEXT')), + (nqp::setelems($!value-buffer, 0)), + nqp::eqaddr($!source.push-exactly($!value-buffer, $!count), IterationEnd) + && nqp::elems($!value-buffer) == 0 + ?? ($result := IterationEnd) + !! ($redo = 1)), + 'REDO', $redo = 1, + 'LAST', nqp::stmts( + ($!did-iterate = 1), + ($result := IterationEnd) + ) + ) + ), + :nohandler); + } + &!block.fire_if_phasers('LAST') + if $!CAN_FIRE_PHASERS + && $!did-iterate + && nqp::eqaddr($result, IterationEnd); + $result + } + } + + sub sequential-map(\source, &block, $label) { + # We want map to be fast, so we go to some effort to build special + # case iterators that can ignore various interesting cases. + my $count = &block.count; + + Seq.new( + nqp::istype(&block,Block) && &block.has-phasers + ?? $count < 2 || $count === Inf + ?? IterateOneWithPhasers.new(&block,source,$label) + !! IterateMoreWithPhasers.new(&block,source,$count,$label) + !! $count < 2 || $count === Inf + ?? nqp::istype(Slip,&block.returns) + ?? IterateOneWithoutPhasers.new(&block,source,$label) + !! IterateOneNotSlippingWithoutPhasers.new(&block,source,$label) + !! $count == 2 + ?? IterateTwoWithoutPhasers.new(&block,source,$label) + !! IterateMoreWithPhasers.new(&block,source,$count,$label) + ) + } + + proto method flatmap (|) is nodal {*} + multi method flatmap(&block, :$label) { + self.map(&block, :$label).flat + } + + method !grep-k(Callable:D $test) { + Seq.new(class :: does Iterator { + has Mu $!iter; + has Mu $!test; + has int $!index; + method !SET-SELF(\list,Mu \test) { + $!iter = list.iterator; + $!test := test; + $!index = -1; + self + } + method new(\list,Mu \test) { nqp::create(self)!SET-SELF(list,test) } + method pull-one() is raw { + $!index = $!index + 1 + until ($_ := $!iter.pull-one) =:= IterationEnd || $!test($_); + $_ =:= IterationEnd + ?? IterationEnd + !! nqp::p6box_i($!index = $!index + 1) + } + method push-all($target --> IterationEnd) { + until ($_ := $!iter.pull-one) =:= IterationEnd { + $!index = $!index + 1; + $target.push(nqp::p6box_i($!index)) if $!test($_); + } + } + }.new(self, $test)) + } + method !grep-kv(Callable:D $test) { + Seq.new(class :: does Iterator { + has Mu $!iter; + has Mu $!test; + has int $!index; + has Mu $!value; + method !SET-SELF(\list,Mu \test) { + $!iter = list.iterator; + $!test := test; + $!index = -1; + self + } + method new(\list,Mu \test) { nqp::create(self)!SET-SELF(list,test) } + method pull-one() is raw { + if $!value.DEFINITE { + my \tmp = $!value; + $!value := nqp::null; + tmp + } + else { + $!index = $!index + 1 + until ($_ := $!iter.pull-one) =:= IterationEnd + || $!test($_); + if $_ =:= IterationEnd { + IterationEnd; + } + else { + $!value := $_; + nqp::p6box_i($!index = $!index + 1) + } + } + } + method push-all($target --> IterationEnd) { + nqp::until( + nqp::eqaddr(($_ := $!iter.pull-one),IterationEnd), + nqp::stmts( + $!index = nqp::add_i($!index,1); + nqp::if( + $!test($_), + nqp::stmts( # doesn't sink + $target.push(nqp::p6box_i($!index)); + $target.push($_); + ) + ) + ) + ); + } + }.new(self, $test)) + } + method !grep-p(Callable:D $test) { + Seq.new(class :: does Iterator { + has Mu $!iter; + has Mu $!test; + has int $!index; + method !SET-SELF(\list,Mu \test) { + $!iter = list.iterator; + $!test := test; + $!index = -1; + self + } + method new(\list,Mu \test) { nqp::create(self)!SET-SELF(list,test) } + method pull-one() is raw { + $!index = $!index + 1 + until ($_ := $!iter.pull-one) =:= IterationEnd || $!test($_); + $_ =:= IterationEnd + ?? IterationEnd + !! Pair.new($!index = $!index + 1,$_) + } + method push-all($target --> IterationEnd) { + until ($_ := $!iter.pull-one) =:= IterationEnd { + $!index = $!index + 1; + $target.push(Pair.new($!index,$_)) if $!test($_); + } + } + }.new(self, $test)) + } + + role Grepper does Iterator { + has Mu $!iter; + has Mu $!test; + method SET-SELF(\list,Mu \test) { + $!iter = list.iterator; + $!test := test; + self + } + method new(\list,Mu \test) { nqp::create(self).SET-SELF(list,test) } + method is-lazy() { $!iter.is-lazy } + } + method !grep-callable(Callable:D $test) { + nqp::if( + $test.count == 1, + sequential-map( + self.iterator, + { nqp::if($test($_),$_,Empty) }, + Any) + , + nqp::stmts( + (my role CheatArity { + has $!arity; + has $!count; + + method set-cheat($new-arity, $new-count --> Nil) { + $!arity = $new-arity; + $!count = $new-count; + } + + method arity(Code:D:) { $!arity } + method count(Code:D:) { $!count } + }), + (my &tester = -> |c { + #note "*cough* {c.perl} -> {$test(|c).perl}"; + next unless $test(|c); + c.list + } but CheatArity), + &tester.set-cheat($test.arity, $test.count), + self.map(&tester) + ) + ) + } + method !grep-accepts(Mu $test) { + Seq.new(class :: does Grepper { + method pull-one() is raw { + nqp::until( + nqp::eqaddr(($_ := $!iter.pull-one),IterationEnd) + || $!test.ACCEPTS($_), + nqp::null + ); + $_ + } + method push-all($target --> IterationEnd) { + nqp::until( + nqp::eqaddr(($_ := $!iter.pull-one),IterationEnd), + nqp::if( # doesn't sink + $!test.ACCEPTS($_), + $target.push($_) + ) + ); + } + }.new(self, $test)) + } + + method !first-result(\index,\value,$what,%a) is raw { + nqp::stmts( + (my $storage := nqp::getattr(%a,Map,'$!storage')), + nqp::if( + nqp::elems($storage), # some adverb + nqp::if( + nqp::iseq_i(nqp::elems($storage),1), # one adverb + nqp::if( + nqp::atkey($storage,"k"), # :k + nqp::p6box_i(index), + nqp::if( + nqp::atkey($storage,"p"), # :p + Pair.new(index,value), + nqp::if( + nqp::atkey($storage,"v"), # :v + value, + nqp::if( + nqp::atkey($storage,"kv"), # :kv + (index,value), + nqp::stmts( # no truthy or different + (my str $key = + nqp::iterkey_s(nqp::shift(nqp::iterator($storage)))), + nqp::if( + (nqp::iseq_s($key,"k") # :!k || :!p || :!kv + || nqp::iseq_s($key,"p") + || nqp::iseq_s($key,"kv")), + value, + nqp::if( + nqp::iseq_s($key,"v"), # :!v + Failure.new("Specified a negated :v adverb"), + Failure.new(X::Adverb.new( # :foo ?? + :$what, + :source(try { self.VAR.name } // self.WHAT.perl), + :unexpected(%a.keys))) + ) + ) + ) + ) + ) + ) + ), + Failure.new(X::Adverb.new( # multiple adverbs ?? + :$what, + :source(try { self.VAR.name } // self.WHAT.perl), + :nogo(%a.keys.grep: /k|v|p/) + :unexpected(%a.keys.grep: { !.match(/k|v|p/) } ))) + ), + value # no adverb + ) + ) + } + + proto method grep(|) is nodal {*} + multi method grep(Bool:D $t) { + X::Match::Bool.new( type => '.grep').throw + } + multi method grep(Mu $t) { + my $storage := nqp::getattr(%_,Map,'$!storage'); + if nqp::iseq_i(nqp::elems($storage),0) { + nqp::istype($t,Regex:D) + ?? self!grep-accepts: $t + !! nqp::istype($t,Callable:D) + ?? self!grep-callable: $t + !! self!grep-accepts: $t + } + elsif nqp::iseq_i(nqp::elems($storage),1) { + if nqp::atkey($storage,"k") { + nqp::istype($t,Regex:D) + ?? self!grep-k: { $t.ACCEPTS($_) } + !! nqp::istype($t,Callable:D) + ?? self!grep-k: $t + !! self!grep-k: { $t.ACCEPTS($_) } + } + elsif nqp::atkey($storage,"kv") { + nqp::istype($t,Regex:D) + ?? self!grep-kv: { $t.ACCEPTS($_) } + !! nqp::istype($t,Callable:D) + ?? self!grep-kv: $t + !! self!grep-kv: { $t.ACCEPTS($_) } + } + elsif nqp::atkey($storage,"p") { + nqp::istype($t,Regex:D) + ?? self!grep-p: { $t.ACCEPTS($_) } + !! nqp::istype($t,Callable:D) + ?? self!grep-p: $t + !! self!grep-p: { $t.ACCEPTS($_) } + } + elsif nqp::atkey($storage,"v") { + nqp::istype($t,Regex:D) + ?? self!grep-accepts: $t + !! nqp::istype($t,Callable:D) + ?? self!grep-callable: $t + !! self!grep-accepts: $t + } + else { + my str $key = + nqp::iterkey_s(nqp::shift(nqp::iterator($storage))); + if nqp::iseq_s($key,"k") || nqp::iseq_s($key,"kv") || nqp::iseq_s($key,"p") { + nqp::istype($t,Regex:D) + ?? self!grep-accepts: $t + !! nqp::istype($t,Callable:D) + ?? self!grep-callable: $t + !! self!grep-accepts: $t + } + else { + nqp::iseq_s($key,"k") + ?? die "Specified a negated :v adverb" + !! X::Adverb.new( + :what, + :source(try { self.VAR.name } // self.WHAT.perl), + :unexpected($key) + ).throw + } + } + } + else { + X::Adverb.new( + :what, + :source(try { self.VAR.name } // self.WHAT.perl), + :nogo(%_.keys.grep: /k|v|kv|p/) + :unexpected(%_.keys.grep: { !.match(/k|v|kv|p/) } ) + ).throw + } + } + + proto method first(|) is nodal {*} + multi method first(Bool:D $t) { + Failure.new(X::Match::Bool.new( type => '.first' )) + } + # need to handle Regex differently, since it is also Callable + multi method first(Regex:D $test, :$end, *%a) is raw { + $end + ?? self!first-accepts-end($test,%a) + !! self!first-accepts($test,%a) + } + multi method first(Callable:D $test, :$end, *%a is copy) is raw { + if $end { + nqp::stmts( + (my $elems = self.elems), + nqp::if( + ($elems && nqp::not_i($elems == Inf)), + nqp::stmts( + (my int $index = $elems), + nqp::while( + nqp::isge_i(($index = nqp::sub_i($index,1)),0), + nqp::if( + $test(self.AT-POS($index)), + return self!first-result( + $index,self.AT-POS($index),'first :end',%a) + ) + ), + Nil + ), + Nil + ) + ) + } + else { + nqp::stmts( + (my $iter := self.iterator), + (my int $index), + nqp::until( + (nqp::eqaddr(($_ := $iter.pull-one),IterationEnd) + || $test($_)), + ($index = nqp::add_i($index,1)) + ), + nqp::if( + nqp::eqaddr($_,IterationEnd), + Nil, + self!first-result($index,$_,'first',%a) + ) + ) + } + } + multi method first(Mu $test = True, :$end, *%a) is raw { + $end + ?? self!first-accepts-end($test,%a) + !! self!first-accepts($test,%a) + } + method !first-accepts(Mu $test,%a) is raw { + nqp::stmts( + (my $iter := self.iterator), + (my int $index), + nqp::until( + (nqp::eqaddr(($_ := $iter.pull-one),IterationEnd) + || $test.ACCEPTS($_)), + ($index = nqp::add_i($index,1)) + ), + nqp::if( + nqp::eqaddr($_,IterationEnd), + Nil, + self!first-result($index,$_,'first',%a) + ) + ) + } + method !first-accepts-end(Mu $test,%a) is raw { + nqp::stmts( + (my $elems = self.elems), + nqp::if( + ($elems && nqp::not_i($elems == Inf)), + nqp::stmts( + (my int $index = $elems), + nqp::while( + nqp::isge_i(($index = nqp::sub_i($index,1)),0), + nqp::if( + $test.ACCEPTS(self.AT-POS($index)), + return self!first-result( + $index,self.AT-POS($index),'first :end',%a) + ) + ), + Nil + ), + Nil + ) + ) + } + method !iterator-and-first($action,\first) is raw { + nqp::if( + self.is-lazy, + X::Cannot::Lazy.new(:$action).throw, + nqp::stmts( + (my $iterator := self.iterator), + nqp::until( + nqp::eqaddr((my $pulled := $iterator.pull-one),IterationEnd), + nqp::if( + nqp::isconcrete($pulled), + nqp::stmts( + (first = $pulled), + (return $iterator) + ) + ) + ), + Mu + ) + ) + } + + proto method min (|) is nodal {*} + multi method min() { + nqp::stmts( + nqp::if( + (my $iter := self!iterator-and-first(".min",my $min)), + nqp::until( + nqp::eqaddr((my $pulled := $iter.pull-one),IterationEnd), + nqp::if( + (nqp::isconcrete($pulled) && $pulled cmp $min < 0), + $min = $pulled + ) + ) + ), + nqp::if(nqp::defined($min),$min,Inf) + ) + } + multi method min(&by) { + nqp::stmts( + (my $cmp := nqp::if( + nqp::iseq_i(&by.arity,2),&by,{ &by($^a) cmp &by($^b) })), + nqp::if( + (my $iter := self!iterator-and-first(".min",my $min)), + nqp::until( + nqp::eqaddr((my $pulled := $iter.pull-one),IterationEnd), + nqp::if( + (nqp::isconcrete($pulled) && $cmp($pulled,$min) < 0), + $min = $pulled + ) + ) + ), + nqp::if(nqp::defined($min),$min,Inf) + ) + } + + proto method max (|) is nodal {*} + multi method max() { + nqp::stmts( + nqp::if( + (my $iter := self!iterator-and-first(".max",my $max)), + nqp::until( + nqp::eqaddr((my $pulled := $iter.pull-one),IterationEnd), + nqp::if( + (nqp::isconcrete($pulled) && $pulled cmp $max > 0), + $max = $pulled + ) + ) + ), + nqp::if(nqp::defined($max),$max,-Inf) + ) + } + multi method max(&by) { + nqp::stmts( + (my $cmp := nqp::if( + nqp::iseq_i(&by.arity,2),&by,{ &by($^a) cmp &by($^b) })), + nqp::if( + (my $iter := self!iterator-and-first(".max",my $max)), + nqp::until( + nqp::eqaddr((my $pulled := $iter.pull-one),IterationEnd), + nqp::if( + (nqp::isconcrete($pulled) && $cmp($pulled,$max) > 0), + $max = $pulled + ) + ) + ), + nqp::if(nqp::defined($max),$max,-Inf) + ) + } + + method !minmax-range-init(\value,\mi,\exmi,\ma,\exma --> Nil) { + mi = value.min; + exmi = value.excludes-min; + ma = value.max; + exma = value.excludes-max; + } + method !minmax-range-check(\value,\mi,\exmi,\ma,\exma --> Nil) { + nqp::stmts( + nqp::if( + ((value.min cmp mi) < 0), + nqp::stmts( + (mi = value.min), + (exmi = value.excludes-min) + ) + ), + nqp::if( + ((value.max cmp ma) > 0), + nqp::stmts( + (ma = value.max), + (exma = value.excludes-max) + ) + ) + ) + } + method !cmp-minmax-range-check(\value,$cmp,\mi,\exmi,\ma,\exma --> Nil) { + nqp::stmts( # $cmp sigillless confuses the optimizer + nqp::if( + ($cmp(value.min,mi) < 0), + nqp::stmts( + (mi = value.min), + (exmi = value.excludes-min) + ) + ), + nqp::if( + ($cmp(value.max,ma) > 0), + nqp::stmts( + (ma = value.max), + (exma = value.excludes-max) + ) + ) + ) + } + + proto method minmax (|) is nodal {*} + multi method minmax() { + nqp::stmts( + nqp::if( + (my $iter := self!iterator-and-first(".minmax",my $pulled)), + nqp::stmts( + nqp::if( + nqp::istype($pulled,Range), + self!minmax-range-init($pulled, + my $min,my int $excludes-min,my $max,my int $excludes-max), + nqp::if( + nqp::istype($pulled,Positional), + self!minmax-range-init($pulled.minmax, # recurse for min/max + $min,$excludes-min,$max,$excludes-max), + ($min = $max = $pulled) + ) + ), + nqp::until( + nqp::eqaddr(($pulled := $iter.pull-one),IterationEnd), + nqp::if( + nqp::isconcrete($pulled), + nqp::if( + nqp::istype($pulled,Range), + self!minmax-range-check($pulled, + $min,$excludes-min,$max,$excludes-max), + nqp::if( + nqp::istype($pulled,Positional), + self!minmax-range-check($pulled.minmax, + $min,$excludes-min,$max,$excludes-max), + nqp::if( + (($pulled cmp $min) < 0), + ($min = $pulled), + nqp::if( + (($pulled cmp $max) > 0), + ($max = $pulled) + ) + ) + ) + ) + ) + ) + ) + ), + nqp::if( + nqp::defined($min), + Range.new($min,$max,:$excludes-min,:$excludes-max), + Range.new(Inf,-Inf) + ) + ) + } + multi method minmax(&by) { + nqp::stmts( + nqp::if( + (my $iter := self!iterator-and-first(".minmax",my $pulled)), + nqp::stmts( + (my $cmp = nqp::if( + nqp::iseq_i(&by.arity,2),&by,{ &by($^a) cmp &by($^b) }) + ), + nqp::if( + nqp::istype($pulled,Range), + self!minmax-range-init($pulled, + my $min,my int $excludes-min,my $max,my int $excludes-max), + nqp::if( + nqp::istype($pulled,Positional), + self!minmax-range-init($pulled.minmax(&by), # recurse min/max + $min,$excludes-min,$max,$excludes-max), + ($min = $max = $pulled) + ) + ), + nqp::until( + nqp::eqaddr(($pulled := $iter.pull-one),IterationEnd), + nqp::if( + nqp::isconcrete($pulled), + nqp::if( + nqp::istype($pulled,Range), + self!cmp-minmax-range-check($pulled, + $cmp,$min,$excludes-min,$max,$excludes-max), + nqp::if( + nqp::istype($pulled,Positional), + self!cmp-minmax-range-check($pulled.minmax(&by), + $cmp,$min,$excludes-min,$max,$excludes-max), + nqp::if( + ($cmp($pulled,$min) < 0), + ($min = $pulled), + nqp::if( + ($cmp($pulled,$max) > 0), + ($max = $pulled) + ) + ) + ) + ) + ) + ) + ) + ), + nqp::if( + nqp::defined($min), + Range.new($min,$max,:$excludes-min,:$excludes-max), + Range.new(Inf,-Inf) + ) + ) + } + + proto method sort(|) is nodal {*} + multi method sort() { + nqp::if( + nqp::eqaddr( + self.iterator.push-until-lazy(my $list := IterationBuffer.new), + IterationEnd + ), + Seq.new( + Rakudo::Iterator.ReifiedList( + Rakudo::Sorting.MERGESORT-REIFIED-LIST( + nqp::p6bindattrinvres(nqp::create(List),List,'$!reified',$list) + ) + ) + ), + X::Cannot::Lazy.new(:action).throw + ) + } + multi method sort(&by) { + nqp::stmts( + nqp::unless( + nqp::eqaddr( + self.iterator.push-until-lazy(my $list := IterationBuffer.new), + IterationEnd + ), + X::Cannot::Lazy.new(:action).throw + ), + Seq.new( + Rakudo::Iterator.ReifiedList( + nqp::if( + nqp::eqaddr(&by,&infix:), + Rakudo::Sorting.MERGESORT-REIFIED-LIST( + nqp::p6bindattrinvres( + nqp::create(List),List,'$!reified',$list) + ), + nqp::if( + &by.count < 2, + Rakudo::Sorting.MERGESORT-REIFIED-LIST-AS( + nqp::p6bindattrinvres( + nqp::create(List),List,'$!reified',$list), + &by + ), + Rakudo::Sorting.MERGESORT-REIFIED-LIST-WITH( + nqp::p6bindattrinvres( + nqp::create(List),List,'$!reified',$list), + &by + ) + ) + ) + ) + ) + ) + } + + method collate { + self.sort(&[coll]); + } + sub find-reducer-for-op(&op) { + nqp::if( + nqp::iseq_s(&op.prec("prec"),"f="), + &METAOP_REDUCE_LISTINFIX, + nqp::if( + nqp::iseq_i(nqp::chars(my str $assoc = &op.prec("assoc")),0), + &METAOP_REDUCE_LEFT, + ::(nqp::concat('&METAOP_REDUCE_',nqp::uc($assoc))) + ) + ) + } + + proto method reduce(|) {*} + multi method reduce(&with) is nodal { + return unless self.DEFINITE; + my $reducer := find-reducer-for-op(&with); + $reducer(&with)(self) if $reducer; + } + + proto method produce(|) {*} + multi method produce(&with) is nodal { + return unless self.DEFINITE; + my $reducer := find-reducer-for-op(&with); + $reducer(&with,1)(self) if $reducer; + } + + proto method unique(|) is nodal {*} + multi method unique() { + Seq.new(class :: does Iterator { + has $!iter; + has $!seen; + method !SET-SELF(\list) { + nqp::stmts( + ($!iter := list.iterator), + ($!seen := nqp::hash), + self + ) + } + method new(\list) { nqp::create(self)!SET-SELF(list) } + method pull-one() is raw { + nqp::stmts( + nqp::until( + nqp::eqaddr((my $pulled := $!iter.pull-one),IterationEnd) + || (nqp::not_i(nqp::existskey( + $!seen, + (my $needle := $pulled.WHICH) + )) && nqp::bindkey($!seen,$needle,1)), + nqp::null + ), + $pulled + ) + } + method push-all($target --> IterationEnd) { + nqp::until( + nqp::eqaddr((my $pulled := $!iter.pull-one),IterationEnd), + nqp::unless( + nqp::existskey($!seen,(my $needle := $pulled.WHICH)), + nqp::stmts( + nqp::bindkey($!seen,$needle,1), + $target.push($pulled) + ) + ) + ) + } + method is-lazy() { $!iter.is-lazy } + method sink-all(--> IterationEnd) { $!iter.sink-all } + }.new(self)) + } + multi method unique( :&as!, :&with! ) { + nqp::if( + nqp::eqaddr(&with,&[===]), # use optimized version + self.unique(:&as), + Seq.new( + Rakudo::Iterator.UniqueRepeatedAsWith(self.iterator,&as,&with,1) + ) + ) + } + multi method unique( :&as! ) { + Seq.new(class :: does Iterator { + has Mu $!iter; + has &!as; + has $!seen; + method !SET-SELF(\list, &!as) { + $!iter = list.iterator; + $!seen := nqp::hash(); + self + } + method new(\list, &as) { nqp::create(self)!SET-SELF(list, &as) } + method pull-one() is raw { + nqp::stmts( + nqp::until( + nqp::eqaddr((my $value := $!iter.pull-one),IterationEnd), + nqp::unless( + nqp::existskey($!seen,my $needle := &!as($value).WHICH), + nqp::stmts( + nqp::bindkey($!seen,$needle,1), + return-rw $value + ) + ) + ), + IterationEnd + ) + } + method push-all($target --> IterationEnd) { + nqp::until( + nqp::eqaddr((my $value := $!iter.pull-one),IterationEnd), + nqp::unless( + nqp::existskey($!seen,my $needle := &!as($value).WHICH), + nqp::stmts( # doesn't sink + nqp::bindkey($!seen,$needle,1), + $target.push($value) + ) + ) + ) + } + }.new(self, &as)) + } + multi method unique( :&with! ) { + nqp::if( + nqp::eqaddr(&with,&[===]), # use optimized version + self.unique, + Seq.new(Rakudo::Iterator.UniqueRepeatedWith(self.iterator,&with,1)) + ) + } + + proto method repeated(|) is nodal {*} + multi method repeated() { + Seq.new(class :: does Iterator { + has Mu $!iter; + has $!seen; + method !SET-SELF(\list) { + $!iter = list.iterator; + $!seen := nqp::hash(); + self + } + method new(\list) { nqp::create(self)!SET-SELF(list) } + method pull-one() is raw { + my Mu $value; + my str $needle; + nqp::until( + nqp::eqaddr(($value := $!iter.pull-one),IterationEnd), + nqp::existskey($!seen,$needle = nqp::unbox_s($value.WHICH)) + ?? return-rw $value + !! nqp::bindkey($!seen, $needle, 1) + ); + IterationEnd + } + method push-all($target --> IterationEnd) { + my Mu $value; + my str $needle; + nqp::until( # doesn't sink + nqp::eqaddr(($value := $!iter.pull-one),IterationEnd), + nqp::existskey($!seen,$needle = nqp::unbox_s($value.WHICH)) + ?? $target.push($value) + !! nqp::bindkey($!seen, $needle, 1) + ); + } + method is-lazy() { $!iter.is-lazy } + }.new(self)) + } + multi method repeated( :&as!, :&with! ) { + nqp::if( + nqp::eqaddr(&with,&[===]), # use optimized version + self.repeated(:&as), + Seq.new( + Rakudo::Iterator.UniqueRepeatedAsWith(self.iterator,&as,&with,0) + ) + ) + } + multi method repeated( :&as! ) { + Seq.new(class :: does Iterator { + has Mu $!iter; + has &!as; + has $!seen; + method !SET-SELF(\list, &!as) { + $!iter = list.iterator; + $!seen := nqp::hash(); + self + } + method new(\list, &as) { nqp::create(self)!SET-SELF(list, &as) } + method pull-one() is raw { + my Mu $value; + my str $needle; + nqp::until( + nqp::eqaddr(($value := $!iter.pull-one),IterationEnd), + nqp::existskey($!seen,$needle = nqp::unbox_s(&!as($value).WHICH)) + ?? return-rw $value + !! nqp::bindkey($!seen, $needle, 1) + ); + IterationEnd + } + method push-all($target --> IterationEnd) { + my Mu $value; + my str $needle; + nqp::until( # doesn't sink + nqp::eqaddr(($value := $!iter.pull-one),IterationEnd), + nqp::existskey($!seen,$needle = nqp::unbox_s(&!as($value).WHICH)) + ?? $target.push($value) + !! nqp::bindkey($!seen, $needle, 1) + ); + } + method is-lazy() { $!iter.is-lazy } + }.new(self, &as)) + } + multi method repeated( :&with! ) { + nqp::if( + nqp::eqaddr(&with,&[===]), # use optimized version + self.repeated, + Seq.new(Rakudo::Iterator.UniqueRepeatedWith(self.iterator,&with,0)) + ) + } + + proto method squish(|) is nodal {*} + multi method squish( :&as!, :&with = &[===] ) { + Seq.new(class :: does Iterator { + has Mu $!iter; + has &!as; + has &!with; + has $!last_as; + has int $!first; + method !SET-SELF(\list, &!as, &!with) { + $!iter = list.iterator; + $!first = 1; + self + } + method new(\list, &as, &with) { + nqp::create(self)!SET-SELF(list, &as, &with) + } + method pull-one() is raw { + my Mu $value := $!iter.pull-one; + unless nqp::eqaddr($value,IterationEnd) { + my $which := &!as($value); + if $!first { + $!first = 0; + } + else { + until !with($!last_as, $which) or ($value := $!iter.pull-one) =:= IterationEnd { + $!last_as = $which; + $which := &!as($value); + } + } + $!last_as = $which; + } + $value; + } + method push-all($target --> IterationEnd) { + my Mu $value := $!iter.pull-one; + unless nqp::eqaddr($value,IterationEnd) { + my $which; + my $last_as := $!last_as; + nqp::if( + $!first, + nqp::stmts( # doesn't sink + ($target.push($value)), + ($which := &!as($value)), + ($last_as := $which), + ($value := $!iter.pull-one) + ) + ); + nqp::until( + nqp::eqaddr($value,IterationEnd), + nqp::stmts( + nqp::unless( # doesn't sink + with($last_as,$which := &!as($value)), + $target.push($value) + ), + ($last_as := $which), + ($value := $!iter.pull-one) + ) + ); + } + } + method is-lazy() { $!iter.is-lazy } + }.new(self, &as, &with)) + } + multi method squish( :&with = &[===] ) { + Seq.new(class :: does Iterator { + has Mu $!iter; + has &!with; + has Mu $!last; + has int $!first; + method !SET-SELF(\list, &!with) { + $!iter = list.iterator; + $!first = 1; + self + } + method new(\list, &with) { nqp::create(self)!SET-SELF(list, &with) } + method pull-one() is raw { + my Mu $value := $!iter.pull-one; + unless nqp::eqaddr($value,IterationEnd) { + if $!first { + $!first = 0; + } + else { + my $ov = $value; + until !with($!last, $value) + or ($value := $!iter.pull-one) =:= IterationEnd { + $!last = $ov; + $ov = $value; + } + } + $!last = $value + } + $value; + } + method push-all($target --> IterationEnd) { + my Mu $value := $!iter.pull-one; + unless nqp::eqaddr($value,IterationEnd) { + my $last_val = $!last; + nqp::if( + $!first, + nqp::stmts( # doesn't sink + ($target.push($value)), + ($last_val := $value), + ($value := $!iter.pull-one) + ) + ); + nqp::until( + nqp::eqaddr($value,IterationEnd), + nqp::stmts( + nqp::unless( # doesn't sink + with($last_val, $value), + $target.push($value) + ), + ($last_val := $value), + ($value := $!iter.pull-one) + ) + ); + } + } + method is-lazy() { $!iter.is-lazy } + }.new(self, &with)) + } + + proto method pairup(|) is nodal {*} + multi method pairup(Any:U:) { () } + multi method pairup(Any:D:) { + my \iter := self.iterator; + gather { + nqp::until( + nqp::eqaddr((my $pulled := iter.pull-one),IterationEnd), + nqp::if( + nqp::istype($pulled,Pair), + (take nqp::p6bindattrinvres( + nqp::clone($pulled), + Pair, + '$!value', + nqp::clone(nqp::decont(nqp::getattr($pulled,Pair,'$!value'))) + )), + nqp::if( + nqp::istype($pulled,Map) && nqp::not_i(nqp::iscont($pulled)), + (take Slip.from-iterator($pulled.iterator)), + nqp::if( + nqp::eqaddr((my $value := iter.pull-one),IterationEnd), + X::Pairup::OddNumber.new.throw, + take Pair.new($pulled,$value) + ) + ) + ) + ) + } + } + + proto method toggle(|) {*} + multi method toggle(Any:D: Callable:D \condition, :$off!) { + Seq.new( $off + ?? Rakudo::Iterator.Until(self.iterator, condition) + !! Rakudo::Iterator.While(self.iterator, condition) + ) + } + multi method toggle(Any:D: Callable:D \condition) { + Seq.new(Rakudo::Iterator.While(self.iterator, condition)) + } + multi method toggle(Any:D: *@conditions, :$off) { + Seq.new( + Rakudo::Iterator.Toggle(self.iterator, @conditions.iterator, !$off) + ) + } + + proto method head(|) {*} + multi method head(Any:D:) is raw { + nqp::if( + nqp::eqaddr((my $pulled := self.iterator.pull-one),IterationEnd), + Nil, + $pulled + ) + } + multi method head(Any:D: Callable:D $w) { + Seq.new( + Rakudo::Iterator.AllButLastNValues(self.iterator,-($w(0).Int)) + ) + } + multi method head(Any:D: $n) { + Seq.new(Rakudo::Iterator.NextNValues(self.iterator,$n)) + } + + proto method tail(|) {*} + multi method tail() is raw { + nqp::if( + nqp::eqaddr((my $pulled := + Rakudo::Iterator.LastValue(self.iterator,'tail')), + IterationEnd + ), + Nil, + $pulled + ) + } + multi method tail($n) { + Seq.new( + nqp::if( + nqp::istype($n,Callable), + nqp::stmts( + (my $iterator := self.iterator), + nqp::if( + nqp::isgt_i((my $skip := -($n(0).Int)),0), + nqp::if( + $iterator.skip-at-least($skip), + $iterator, + Rakudo::Iterator.Empty), + $iterator)), + Rakudo::Iterator.LastNValues(self.iterator,$n,'tail') + ) + ) + } + + proto method skip(|) {*} + multi method skip() { + my $iter := self.iterator; + Seq.new( $iter.skip-one ?? $iter !! Rakudo::Iterator.Empty ) + } + multi method skip(Whatever) { Seq.new(Rakudo::Iterator.Empty) } + multi method skip(Callable:D $w) { + nqp::if( + nqp::isgt_i((my $tail := -($w(0).Int)),0), + self.tail($tail), + Seq.new(Rakudo::Iterator.Empty) + ) + } + multi method skip(Int() $n) { + my $iter := self.iterator; + Seq.new( $iter.skip-at-least($n) ?? $iter !! Rakudo::Iterator.Empty ) + } + + proto method minpairs(|) {*} + multi method minpairs(Any:D:) { + my @found; + for self.pairs { + my $value := .value; + state $min = $value; + nqp::if( + nqp::iseq_i( (my $cmp := $value cmp $min), -1 ), + nqp::stmts((@found = $_), ($min = $value)), + nqp::if( + nqp::iseq_i($cmp, 0), + @found.push($_) + ) + ) + } + Seq.new(@found.iterator) + } + + proto method maxpairs(|) {*} + multi method maxpairs(Any:D:) { + my @found; + for self.pairs { + my $value := .value; + state $max = $value; + nqp::if( + nqp::iseq_i( (my $cmp := $value cmp $max), 1 ), + nqp::stmts((@found = $_), ($max = $value)), + nqp::if( + nqp::iseq_i($cmp, 0), + @found.push($_) + ) + ) + } + Seq.new(@found.iterator) + } + + proto method batch(|) is nodal {*} + multi method batch(Any:D: Int:D :$elems!) { + Seq.new(Rakudo::Iterator.Batch(self.iterator,$elems,1)) + } + multi method batch(Any:D: Int:D $batch) { + Seq.new(Rakudo::Iterator.Batch(self.iterator,$batch,1)) + } + + proto method rotor(|) is nodal {*} + multi method rotor(Any:D: Int:D $batch, :$partial) { + Seq.new(Rakudo::Iterator.Batch(self.iterator,$batch,$partial)) + } + multi method rotor(Any:D: *@cycle, :$partial) { + Seq.new(Rakudo::Iterator.Rotor(self.iterator,@cycle,$partial)) + } +} + +BEGIN Attribute.^compose; + +proto sub infix:(|) is pure {*} +multi sub infix:(Mu:D \a, Mu:U) { a } +multi sub infix:(Mu:U, Mu:D \b) { b } +multi sub infix:(Mu:D \a, Mu:D \b) { (a cmp b) < 0 ?? a !! b } +multi sub infix:(Int:D \a, Int:D \b) { nqp::if(nqp::islt_i(nqp::cmp_I(nqp::decont(a), nqp::decont(b)), 0), a, b) } +multi sub infix:(int \a, int \b) { nqp::if(nqp::islt_i(nqp::cmp_i(a, b), 0), a, b) } +multi sub infix:(Num:D \a, Num:D \b) { nqp::if(nqp::islt_i(nqp::cmp_n(a, b), 0), a, b) } +multi sub infix:(num \a, num \b) { nqp::if(nqp::islt_i(nqp::cmp_n(a, b), 0), a, b) } +multi sub infix:(+args is raw) { args.min } + +proto sub min(|) is pure {*} +multi sub min(+args, :&by!) { args.min(&by) } +multi sub min(+args) { args.min } + +proto sub infix:(|) is pure {*} +multi sub infix:(Mu:D \a, Mu:U) { a } +multi sub infix:(Mu:U, Mu:D \b) { b } +multi sub infix:(Mu:D \a, Mu:D \b) { (a cmp b) > 0 ?? a !! b } +multi sub infix:(Int:D \a, Int:D \b) { nqp::if(nqp::isgt_i(nqp::cmp_I(nqp::decont(a), nqp::decont(b)), 0), a, b) } +multi sub infix:(int \a, int \b) { nqp::if(nqp::isgt_i(nqp::cmp_i(a, b), 0), a, b) } +multi sub infix:(Num:D \a, Num:D \b) { nqp::if(nqp::isgt_i(nqp::cmp_n(a, b), 0), a, b) } +multi sub infix:(num \a, num \b) { nqp::if(nqp::isgt_i(nqp::cmp_n(a, b), 0), a, b) } +multi sub infix:(+args) { args.max } + +proto sub max(|) is pure {*} +multi sub max(+args, :&by!) { args.max(&by) } +multi sub max(+args) { args.max } + +proto sub infix:(|) is pure {*} +multi sub infix:(+args) { args.minmax } + +proto sub minmax(|) is pure {*} +multi sub minmax(+args, :&by!) { args.minmax(&by) } +multi sub minmax(+args) { args.minmax } + +proto sub map(|) {*} +multi sub map(&code, +values) { my $laze = values.is-lazy; values.map(&code).lazy-if($laze) } + +proto sub grep(|) {*} +multi sub grep(Mu $test, +values, *%a) { + my $laze = values.is-lazy; + values.grep($test,|%a).lazy-if($laze) +} +multi sub grep(Bool:D $t, |) { X::Match::Bool.new(:type).throw } + +proto sub first(|) {*} +multi sub first(Bool:D $t, |) { Failure.new(X::Match::Bool.new(:type)) } +multi sub first(Mu $test, +values, *%a) { values.first($test,|%a) } + +proto sub join(|) {*} +multi sub join($sep = '', *@values) { @values.join($sep) } + +proto sub reduce (|) {*} +multi sub reduce (&with, +list) { list.reduce(&with) } + +proto sub produce (|) {*} +multi sub produce (&with, +list) { list.produce(&with) } + +proto sub unique(|) {*} +multi sub unique(+values, |c) { my $laze = values.is-lazy; values.unique(|c).lazy-if($laze) } + +proto sub squish(|) {*} +multi sub squish(+values, |c) { my $laze = values.is-lazy; values.squish(|c).lazy-if($laze) } + +proto sub repeated(|) {*} +multi sub repeated(+values, |c) { my $laze = values.is-lazy; values.repeated(|c).lazy-if($laze) } + +proto sub sort(|) {*} +multi sub sort(&by, @values) { @values.sort(&by) } +multi sub sort(&by, +values) { values.sort(&by) } +multi sub sort(@values) { @values.sort } +multi sub sort(+values) { values.sort } + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Any.pm rakudo-2018.03/src/core/Any.pm --- rakudo-2018.02.1/src/core/Any.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Any.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,625 +0,0 @@ -my class Pair { ... } -my class Range { ... } -my class Seq { ... } -my class X::Adverb { ... } -my class X::Bind { ... } -my class X::Bind::Slice { ... } -my class X::Bind::ZenSlice { ... } -my class X::Item { ... } -my class X::Match::Bool { ... } -my class X::Pairup::OddNumber { ... } -my class X::Subscript::Negative { ... } - -my role Numeric { ... } - -my class Any { # declared in BOOTSTRAP - # my class Any is Mu - - multi method ACCEPTS(Any:D: Mu:D \a) { self === a } - multi method ACCEPTS(Any:D: Mu:U $ --> False) { } - multi method ACCEPTS(Any:U: Any \topic) { # use of Any on topic to force autothreading - nqp::p6bool(nqp::istype(topic, self)) # so that all(@foo) ~~ Type works as expected - } - - proto method EXISTS-KEY(|) is nodal {*} - multi method EXISTS-KEY(Any:U: $ --> False) { } - multi method EXISTS-KEY(Any:D: $ --> False) { } - - proto method DELETE-KEY(|) is nodal {*} - multi method DELETE-KEY(Any:U: $ --> Nil) { } - multi method DELETE-KEY(Any:D: $) { - Failure.new("Can not remove values from a {self.^name}") - } - - proto method DELETE-POS(|) is nodal {*} - multi method DELETE-POS(Any:U: $pos --> Nil) { } - multi method DELETE-POS(Any:D: $pos) { - Failure.new("Can not remove elements from a {self.^name}") - } - multi method DELETE-POS(Any:D: \one, \two) is raw { - self.AT-POS(one).DELETE-POS(two) - } - multi method DELETE-POS(Any:D: \one, \two, \three) is raw { - self.AT-POS(one).AT-POS(two).DELETE-POS(three) - } - multi method DELETE-POS(Any:D: **@indices) { - my $final := @indices.pop; - Rakudo::Internals.WALK-AT-POS(self,@indices).DELETE-POS($final) - } - - method cache() { self.list } - - proto method list(|) is nodal {*} - multi method list(Any:U:) { infix:<,>(self) } - multi method list(Any:D \SELF:) { infix:<,>(SELF) } - - proto method flat(|) is nodal {*} - multi method flat() { self.list.flat } - - proto method eager(|) is nodal {*} - multi method eager() { self.list.eager } - - proto method serial(|) is nodal {*} - multi method serial() { self } - - # derived from .list - proto method List(|) is nodal {*} - multi method List() { self.list } - proto method Slip(|) is nodal {*} - multi method Slip() { self.list.Slip } - proto method Array(|) is nodal {*} - multi method Array() { self.list.Array } - proto method Seq(|) is nodal {*} - multi method Seq() { Seq.new(self.iterator) } - - proto method hash(|) is nodal {*} - multi method hash(Any:U:) { my % = () } - multi method hash(Any:D:) { my % = self } - - # derived from .hash - proto method Hash(|) is nodal {*} - multi method Hash() { self.hash.Hash } - - proto method Map(|) is nodal {*} - multi method Map() { self.hash.Map } - - proto method elems(|) is nodal {*} - multi method elems(Any:U: --> 1) { } - multi method elems(Any:D:) { self.list.elems } - - proto method end(|) is nodal {*} - multi method end(Any:U: --> 0) { } - multi method end(Any:D:) { self.list.end } - - proto method keys(|) is nodal {*} - multi method keys(Any:U:) { () } - multi method keys(Any:D:) { self.list.keys } - - proto method kv(|) is nodal {*} - multi method kv(Any:U:) { () } - multi method kv(Any:D:) { self.list.kv } - - proto method values(|) is nodal {*} - multi method values(Any:U:) { () } - multi method values(Any:D:) { self.list } - - proto method pairs(|) is nodal {*} - multi method pairs(Any:U:) { () } - multi method pairs(Any:D:) { self.list.pairs } - - proto method antipairs(|) is nodal {*} - multi method antipairs(Any:U:) { () } - multi method antipairs(Any:D:) { self.list.antipairs } - - proto method invert(|) is nodal {*} - multi method invert(Any:U:) { () } - multi method invert(Any:D:) { self.list.invert } - - proto method pick(|) is nodal {*} - multi method pick() { self.list.pick } - multi method pick($n) { self.list.pick($n) } - - proto method roll(|) is nodal {*} - multi method roll() { self.list.roll } - multi method roll($n) { self.list.roll($n) } - - multi method iterator(Any:) { self.list.iterator } - - method match(Any:U: |) { self.Str; nqp::getlexcaller('$/') = Nil } - - proto method classify(|) is nodal {*} - multi method classify() { - die "Must specify something to classify with, a Callable, Hash or List"; - } - multi method classify(Whatever) { - die "Doesn't make sense to classify with itself"; - } - multi method classify($test, :$into!, :&as) { - ( $into // $into.new ).classify-list( $test, self, :&as); - } - multi method classify($test, :&as) { - Hash.^parameterize(Any,Any).new.classify-list( $test, self, :&as ); - } - - proto method categorize(|) is nodal {*} - multi method categorize() { - die "Must specify something to categorize with, a Callable, Hash or List"; - } - multi method categorize(Whatever) { - die "Doesn't make sense to categorize with itself"; - } - multi method categorize($test, :$into!, :&as) { - ( $into // $into.new ).categorize-list( $test, self.list, :&as ); - } - multi method categorize($test, :&as) { - Hash.^parameterize(Any,Any).new.categorize-list($test, self.list, :&as); - } - - method reverse() is nodal { self.list.reverse } - method combinations(|c) is nodal { self.list.combinations(|c) } - method permutations(|c) is nodal { self.list.permutations(|c) } - method join($separator = '') is nodal { self.list.join($separator) } - - # XXX GLR should move these - method nodemap(&block) is nodal { nodemap(&block, self) } - method duckmap(&block) is nodal { duckmap(&block, self) } - method deepmap(&block) is nodal { deepmap(&block, self) } - - # XXX GLR Do we need tree post-GLR? - proto method tree(|) is nodal {*} - multi method tree(Any:U:) { self } - multi method tree(Any:D:) { - nqp::istype(self, Iterable) - ?? self.map({ .tree }).item - !! self - } - multi method tree(Any:D: Whatever ) { self.tree } - multi method tree(Any:D: Int(Cool) $count) { - nqp::istype(self, Iterable) && $count > 0 - ?? self.map({ .tree($count - 1) }).item - !! self - } - multi method tree(Any:D: @ [&first, *@rest]) { self.tree(&first, |@rest); } - multi method tree(Any:D: &first, *@rest) { - nqp::istype(self, Iterable) - ?? @rest ?? first(self.map({ .tree(|@rest) })) - !! first(self) - !! self - } - - # auto-vivifying - proto method push(|) is nodal {*} - multi method push(Any:U \SELF: |values) { - SELF = nqp::istype(SELF,Positional) ?? SELF.new !! Array.new; - SELF.push(|values); - } - - proto method append(|) is nodal {*} - multi method append(Any:U \SELF: |values) { - SELF = nqp::istype(SELF,Positional) ?? SELF.new !! Array.new; - SELF.append(|values); - } - - proto method unshift(|) is nodal {*} - multi method unshift(Any:U \SELF: |values) { - SELF = Array.new; - SELF.unshift(|values); - } - - proto method prepend(|) is nodal {*} - multi method prepend(Any:U \SELF: |values) { - SELF = Array.new; - SELF.prepend(|values); - } - - proto method EXISTS-POS(|) is nodal {*} - multi method EXISTS-POS(Any:U: Any:D $ --> False) { } - multi method EXISTS-POS(Any:U: Any:U $pos) { - die "Cannot use '{$pos.^name}' as an index"; - } - - multi method EXISTS-POS(Any:D: int \pos) { - nqp::p6bool(nqp::iseq_i(pos,0)); - } - multi method EXISTS-POS(Any:D: Int:D \pos) { - pos == 0; - } - multi method EXISTS-POS(Any:D: Num:D \pos) { - X::Item.new(aggregate => self, index => pos).throw - if nqp::isnanorinf(pos); - self.AT-POS(nqp::unbox_i(pos.Int)); - pos == 0; - } - multi method EXISTS-POS(Any:D: Any:D \pos) { - pos.Int == 0; - } - multi method EXISTS-POS(Any:D: Any:U \pos) { - die "Cannot use '{pos.^name}' as an index"; - } - multi method EXISTS-POS(Any:D: \one, \two) is raw { - self.AT-POS(one).EXISTS-POS(two) - } - multi method EXISTS-POS(Any:D: \one, \two,\three) is raw { - self.AT-POS(one).AT-POS(two).EXISTS-POS(three) - } - multi method EXISTS-POS(Any:D: **@indices) { - my $final := @indices.pop; - Rakudo::Internals.WALK-AT-POS(self,@indices).EXISTS-POS($final) - } - - proto method AT-POS(|) is nodal {*} - multi method AT-POS(Any:U \SELF: int \pos) is raw { - nqp::p6bindattrinvres( - my $scalar, - Scalar, - '$!whence', - -> { nqp::if( - nqp::isconcrete(SELF), - SELF, - (SELF = Array.new) - ).BIND-POS(pos, $scalar) - } - ) - } - multi method AT-POS(Any:U \SELF: Int:D \pos) is raw { - nqp::p6bindattrinvres( - my $scalar, - Scalar, - '$!whence', - -> { nqp::if( - nqp::isconcrete(SELF), - SELF, - (SELF = Array.new) - ).BIND-POS(pos, $scalar) - } - ) - } - multi method AT-POS(Any:U: Num:D \pos) is raw { - nqp::isnanorinf(pos) - ?? Failure.new(X::Item.new(aggregate => self, index => pos)) - !! self.AT-POS(nqp::unbox_i(pos.Int)) - } - multi method AT-POS(Any:U: Any:D \pos) is raw { - self.AT-POS(nqp::unbox_i(pos.Int)); - } - - multi method AT-POS(Any:D: int \pos) is raw { - pos - ?? Failure.new(X::OutOfRange.new( - :what($*INDEX // 'Index'), :got(pos), :range<0..0>)) - !! self - } - multi method AT-POS(Any:D: Int:D \pos) is raw { - pos - ?? Failure.new(X::OutOfRange.new( - :what($*INDEX // 'Index'), :got(pos), :range<0..0>)) - !! self - } - multi method AT-POS(Any:D: Num:D \pos) is raw { - nqp::isnanorinf(pos) - ?? Failure.new(X::Item.new(aggregate => self, index => pos)) - !! self.AT-POS(nqp::unbox_i(pos.Int)) - } - multi method AT-POS(Any:D: Any:D \pos) is raw { - self.AT-POS(nqp::unbox_i(pos.Int)); - } - multi method AT-POS(Any: Any:U \pos) is raw { - die "Cannot use '{pos.^name}' as an index"; - } - multi method AT-POS(Any:D: \one, \two) is raw { - self.AT-POS(one).AT-POS(two) - } - multi method AT-POS(Any:D: \one, \two, \three) is raw { - self.AT-POS(one).AT-POS(two).AT-POS(three) - } - multi method AT-POS(Any:D: **@indices) is raw { - my $final := @indices.pop; - Rakudo::Internals.WALK-AT-POS(self,@indices).AT-POS($final) - } - - proto method ZEN-POS(|) {*} - multi method ZEN-POS(*%unexpected) { - %unexpected - ?? Failure.new(X::Adverb.new( - :what('[] slice'), - :source(try { self.VAR.name } // self.WHAT.perl), - :unexpected(%unexpected.keys))) - !! self - } - - proto method ZEN-KEY(|) {*} - multi method ZEN-KEY(*%unexpected) { - %unexpected - ?? Failure.new(X::Adverb.new( - :what('{} slice'), - :source(try { self.VAR.name } // self.WHAT.perl), - :unexpected(%unexpected.keys))) - !! self - } - - proto method ASSIGN-POS(|) is nodal {*} - multi method ASSIGN-POS(Any:U \SELF: \pos, Mu \assignee) { - SELF.AT-POS(pos) = assignee; # defer < 0 check - } - - multi method ASSIGN-POS(Any:D: int \pos, Mu \assignee) { - self.AT-POS(pos) = assignee; # defer < 0 check - } - multi method ASSIGN-POS(Any:D: Int:D \pos, Mu \assignee) { - self.AT-POS(pos) = assignee; # defer < 0 check - } - multi method ASSIGN-POS(Any:D: Num:D \pos, Mu \assignee) { - nqp::isnanorinf(pos) - ?? Failure.new(X::Item.new(aggregate => self, index => pos)) - !! self.AT-POS(nqp::unbox_i(pos.Int)) = assignee; # defer < 0 check - } - multi method ASSIGN-POS(Any:D: Any:D \pos, Mu \assignee) { - self.AT-POS(nqp::unbox_i(pos.Int)) = assignee; # defer < 0 check - } - multi method ASSIGN-POS(Any:D: Any:U \pos, Mu \assignee) { - die "Cannot use '{pos.^name}' as an index"; - } - multi method ASSIGN-POS(Any:D: \one, \two, Mu \assignee) is raw { - self.AT-POS(one).ASSIGN-POS(two, assignee) - } - multi method ASSIGN-POS(Any:D: \one, \two, \three, Mu \assignee) is raw { - self.AT-POS(one).AT-POS(two).ASSIGN-POS(three, assignee) - } - multi method ASSIGN-POS(Any:D: **@indices) { - my \value := @indices.pop; - my $final := @indices.pop; - Rakudo::Internals.WALK-AT-POS(self,@indices).ASSIGN-POS($final,value) - } - - proto method BIND-POS(|) {*} - multi method BIND-POS(Any:D: **@indices is raw) is raw { -# looks like Array.pop doesn't really return a bindable container -# my \value := @indices.pop; -# my $final := @indices.pop; -# Rakudo::Internals.WALK-AT-POS(self,@indices).BIND-POS($final,value) - - my int $elems = @indices.elems; # reifies - my \value := @indices.AT-POS(--$elems); - my $final := @indices.AT-POS(--$elems); - my $target := self; - my int $i = -1; - $target := $target.AT-POS(@indices.AT-POS($i)) - while nqp::islt_i(++$i,$elems); - X::Bind.new.throw if $target =:= self; - $target.BIND-POS($final, value) - } - - method all() is nodal { Junction.new("all", self) } - method any() is nodal { Junction.new("any", self) } - method one() is nodal { Junction.new("one", self) } - method none() is nodal { Junction.new("none",self) } - - # internals - proto method AT-KEY(|) is nodal {*} - multi method AT-KEY(Any:D: $key) is raw { - Failure.new( self ~~ Associative - ?? "Associative indexing implementation missing from type {self.WHAT.perl}" - !! "Type {self.WHAT.perl} does not support associative indexing." - ) - } - multi method AT-KEY(Any:U \SELF: \key) is raw { - nqp::p6bindattrinvres( - my $scalar, - Scalar, - '$!whence', - # NOTE: even though the signature indicates a non-concrete SELF, - # by the time the below code is executed, it *may* have become - # concrete: and then we don't want the execution to reset it to - # an empty Hash. - -> { nqp::if( - nqp::isconcrete(SELF), - SELF, - (SELF = nqp::create(Hash)) - ).BIND-KEY(key, $scalar) - } - ) - } - - proto method BIND-KEY(|) is nodal {*} - multi method BIND-KEY(Any:D: \k, \v) is raw { - X::Bind.new(target => self.^name).throw - } - multi method BIND-KEY(Any:U \SELF: $key, $BIND ) is raw { - SELF = Hash.new; - SELF.BIND-KEY($key, $BIND); - $BIND - } - - proto method ASSIGN-KEY(|) is nodal {*} - multi method ASSIGN-KEY(\SELF: \key, Mu \assignee) is raw { - SELF.AT-KEY(key) = assignee; - } - - # XXX GLR review these - method FLATTENABLE_LIST() is nodal { - my $list := self.list; - nqp::findmethod($list, 'FLATTENABLE_LIST')($list); - } - method FLATTENABLE_HASH() is nodal { nqp::hash() } - - proto method Set(|) is nodal {*} - multi method Set(Any:) { Set.new-from-pairs(self.list) } - - proto method SetHash(|) is nodal {*} - multi method SetHash(Any:) { SetHash.new-from-pairs(self.list) } - - proto method Bag(|) is nodal {*} - multi method Bag(Any:) { Bag.new-from-pairs(self.list) } - - proto method BagHash(|) is nodal {*} - multi method BagHash(Any:) { BagHash.new-from-pairs(self.list) } - - proto method Mix(|) is nodal {*} - multi method Mix(Any:) { Mix.new-from-pairs(self.list) } - - proto method MixHash(|) is nodal {*} - multi method MixHash() { MixHash.new-from-pairs(self.list) } - - # XXX GLR does this really need to force a list? - proto method Supply(|) is nodal {*} - multi method Supply() { self.list.Supply } - - method nl-out() { "\n" } - method print-nl() { self.print(self.nl-out) } - - method lazy-if($flag) { self } # no-op on non-Iterables - - method sum() is nodal { - my \iter = self.iterator; - my $sum = 0; - my Mu $value; - nqp::until( - nqp::eqaddr(($value := iter.pull-one),IterationEnd), - ($sum = $sum + $value) - ); - $sum; - } -} -Metamodel::ClassHOW.exclude_parent(Any); - -# builtin ops -proto sub infix:<===>(Mu $?, Mu $?) is pure {*} -multi sub infix:<===>($?) { Bool::True } -multi sub infix:<===>(\a, \b) { - nqp::p6bool( - nqp::eqaddr(nqp::decont(a),nqp::decont(b)) - || (nqp::eqaddr(a.WHAT,b.WHAT) - && nqp::iseq_s(nqp::unbox_s(a.WHICH), nqp::unbox_s(b.WHICH))) - ) -} - -proto sub infix:(Mu $?, Mu $?) is pure {*} -multi sub infix:($?) { Bool::True } -multi sub infix:(\a, \b) { (a cmp b) < 0 } - -proto sub infix:(Mu $?, Mu $?) is pure {*} -multi sub infix:($x?) { Bool::True } -multi sub infix:(\a, \b) { (a cmp b) > 0 } - -proto prefix:<++>(Mu) {*} -multi prefix:<++>(Mu:D $a is rw) { $a = $a.succ } -multi prefix:<++>(Mu:U $a is rw) { $a = 1 } -proto prefix:<-->(Mu) {*} -multi prefix:<-->(Mu:D $a is rw) { $a = $a.pred } -multi prefix:<-->(Mu:U $a is rw) { $a = -1 } - -proto postfix:<++>(Mu) {*} -multi postfix:<++>(Mu:D $a is rw) { my $b = $a; $a = $a.succ; $b } -multi postfix:<++>(Mu:U $a is rw) { $a = 1; 0 } -proto postfix:<-->(Mu) {*} -multi postfix:<-->(Mu:D $a is rw) { my $b = $a; $a = $a.pred; $b } -multi postfix:<-->(Mu:U $a is rw) { $a = -1; 0 } - -proto sub pick(|) {*} -multi sub pick($n, +values) { values.pick($n) } - -proto sub roll(|) {*} -multi sub roll($n, +values) { values.roll($n) } - -proto sub keys(|) {*} -multi sub keys($x) { $x.keys } - -proto sub values(|) {*} -multi sub values($x) { $x.values } - -proto sub pairs(|) {*} -multi sub pairs($x) { $x.pairs } - -proto sub kv(|) {*} -multi sub kv($x) { $x.kv } - -proto sub elems(|) is nodal {*} -multi sub elems($a) { $a.elems } - -proto sub end(|) {*} -multi sub end($a) { $a.end } - -proto sub sum(|) {*} -multi sub sum() { 0 } -multi sub sum(\SELF) { SELF.sum } -multi sub sum(+SELF) { SELF.sum } - -sub classify( $test, +items, *%named ) { - if %named.EXISTS-KEY("into") { - my $into := %named.DELETE-KEY("into"); - ( $into // $into.new).classify-list($test, items, |%named); - } - else { - Hash.^parameterize(Any,Any).new.classify-list($test, items, |%named); - } -} -sub categorize( $test, +items, *%named ) { - if %named.EXISTS-KEY("into") { - my $into := %named.DELETE-KEY("into"); - ( $into // $into.new).categorize-list($test, items, |%named); - } - else { - Hash.^parameterize(Any,Any).new.categorize-list($test, items, |%named); - } -} - -proto sub item(|) is pure {*} -multi sub item(\x) { my $ = x } -multi sub item(|c) { my $ = c.list } -multi sub item(Mu $a) { $a } - -sub SLICE_HUH(\SELF, @nogo, %d, %adv) { - @nogo.unshift('delete') # recover any :delete if necessary - if @nogo && @nogo[0] ne 'delete' && %adv.EXISTS-KEY('delete'); - for -> $valid { # check all valid params - if nqp::existskey(%d,nqp::unbox_s($valid)) { - nqp::deletekey(%d,nqp::unbox_s($valid)); - @nogo.push($valid); - } - } - - Failure.new(X::Adverb.new( - :what, - :source(try { SELF.VAR.name } // SELF.WHAT.perl), - :unexpected(%d.keys), - :nogo(@nogo), - )) -} #SLICE_HUH - -sub DELETEKEY(Mu \d, str $key) { - nqp::if( - nqp::existskey(d,$key), - nqp::stmts( - (my Mu $value := nqp::atkey(d,$key)), - (nqp::deletekey(d,$key)), - $value - ), - Nil - ) -} #DELETEKEY - -sub dd(|) { - my Mu $args := nqp::p6argvmarray(); - if nqp::elems($args) { - while $args { - my $var := nqp::shift($args); - my $name := try $var.VAR.?name; - my $type := $var.WHAT.^name; - my $what := nqp::can($var, 'is-lazy') && $var.is-lazy - ?? $var[^10].perl.chop ~ "... lazy list)" - !! nqp::can($var, 'perl') - ?? $var.perl - !! "($var.^name() without .perl method)"; - note $name ?? "$type $name = $what" !! $what; - } - } - else { # tell where we are - note .name - ?? "{lc .^name} {.name}{.signature.gist}" - !! "{lc .^name} {.signature.gist}" - with callframe(1).code; - } - return -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Any.pm6 rakudo-2018.03/src/core/Any.pm6 --- rakudo-2018.02.1/src/core/Any.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Any.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,610 @@ +my class Pair { ... } +my class Range { ... } +my class Seq { ... } +my class X::Adverb { ... } +my class X::Bind { ... } +my class X::Bind::Slice { ... } +my class X::Bind::ZenSlice { ... } +my class X::Item { ... } +my class X::Match::Bool { ... } +my class X::Pairup::OddNumber { ... } +my class X::Subscript::Negative { ... } + +my role Numeric { ... } + +my class Any { # declared in BOOTSTRAP + # my class Any is Mu + + multi method ACCEPTS(Any:D: Mu:D \a) { self === a } + multi method ACCEPTS(Any:D: Mu:U $ --> False) { } + multi method ACCEPTS(Any:U: Any \topic) { # use of Any on topic to force autothreading + nqp::p6bool(nqp::istype(topic, self)) # so that all(@foo) ~~ Type works as expected + } + + proto method EXISTS-KEY(|) is nodal {*} + multi method EXISTS-KEY(Any:U: $ --> False) { } + multi method EXISTS-KEY(Any:D: $ --> False) { } + + proto method DELETE-KEY(|) is nodal {*} + multi method DELETE-KEY(Any:U: $ --> Nil) { } + multi method DELETE-KEY(Any:D: $) { + Failure.new("Can not remove values from a {self.^name}") + } + + proto method DELETE-POS(|) is nodal {*} + multi method DELETE-POS(Any:U: $pos --> Nil) { } + multi method DELETE-POS(Any:D: $pos) { + Failure.new("Can not remove elements from a {self.^name}") + } + multi method DELETE-POS(Any:D: \one, \two) is raw { + self.AT-POS(one).DELETE-POS(two) + } + multi method DELETE-POS(Any:D: \one, \two, \three) is raw { + self.AT-POS(one).AT-POS(two).DELETE-POS(three) + } + multi method DELETE-POS(Any:D: **@indices) { + my $final := @indices.pop; + Rakudo::Internals.WALK-AT-POS(self,@indices).DELETE-POS($final) + } + + method cache() { self.list } + + proto method list(|) is nodal {*} + multi method list(Any:U:) { infix:<,>(self) } + multi method list(Any:D \SELF:) { infix:<,>(SELF) } + + proto method flat(|) is nodal {*} + multi method flat() { self.list.flat } + + proto method eager(|) is nodal {*} + multi method eager() { self.list.eager } + + proto method serial(|) is nodal {*} + multi method serial() { self } + + # derived from .list + proto method List(|) is nodal {*} + multi method List() { self.list } + proto method Slip(|) is nodal {*} + multi method Slip() { self.list.Slip } + proto method Array(|) is nodal {*} + multi method Array() { self.list.Array } + proto method Seq(|) is nodal {*} + multi method Seq() { Seq.new(self.iterator) } + + proto method hash(|) is nodal {*} + multi method hash(Any:U:) { my % = () } + multi method hash(Any:D:) { my % = self } + + # derived from .hash + proto method Hash(|) is nodal {*} + multi method Hash() { self.hash.Hash } + + proto method Map(|) is nodal {*} + multi method Map() { self.hash.Map } + + proto method elems(|) is nodal {*} + multi method elems(Any:U: --> 1) { } + multi method elems(Any:D:) { self.list.elems } + + proto method end(|) is nodal {*} + multi method end(Any:U: --> 0) { } + multi method end(Any:D:) { self.list.end } + + proto method keys(|) is nodal {*} + multi method keys(Any:U:) { () } + multi method keys(Any:D:) { self.list.keys } + + proto method kv(|) is nodal {*} + multi method kv(Any:U:) { () } + multi method kv(Any:D:) { self.list.kv } + + proto method values(|) is nodal {*} + multi method values(Any:U:) { () } + multi method values(Any:D:) { self.list } + + proto method pairs(|) is nodal {*} + multi method pairs(Any:U:) { () } + multi method pairs(Any:D:) { self.list.pairs } + + proto method antipairs(|) is nodal {*} + multi method antipairs(Any:U:) { () } + multi method antipairs(Any:D:) { self.list.antipairs } + + proto method invert(|) is nodal {*} + multi method invert(Any:U:) { () } + multi method invert(Any:D:) { self.list.invert } + + proto method pick(|) is nodal {*} + multi method pick() { self.list.pick } + multi method pick($n) { self.list.pick($n) } + + proto method roll(|) is nodal {*} + multi method roll() { self.list.roll } + multi method roll($n) { self.list.roll($n) } + + multi method iterator(Any:) { self.list.iterator } + + method match(Any:U: |) { self.Str; nqp::getlexcaller('$/') = Nil } + + proto method classify(|) is nodal {*} + multi method classify() { + die "Must specify something to classify with, a Callable, Hash or List"; + } + multi method classify(Whatever) { + die "Doesn't make sense to classify with itself"; + } + multi method classify($test, :$into!, :&as) { + ( $into // $into.new ).classify-list( $test, self, :&as); + } + multi method classify($test, :&as) { + Hash.^parameterize(Any,Any).new.classify-list( $test, self, :&as ); + } + + proto method categorize(|) is nodal {*} + multi method categorize() { + die "Must specify something to categorize with, a Callable, Hash or List"; + } + multi method categorize(Whatever) { + die "Doesn't make sense to categorize with itself"; + } + multi method categorize($test, :$into!, :&as) { + ( $into // $into.new ).categorize-list( $test, self.list, :&as ); + } + multi method categorize($test, :&as) { + Hash.^parameterize(Any,Any).new.categorize-list($test, self.list, :&as); + } + + method reverse() is nodal { self.list.reverse } + method combinations(|c) is nodal { self.list.combinations(|c) } + method permutations(|c) is nodal { self.list.permutations(|c) } + method join($separator = '') is nodal { self.list.join($separator) } + + # XXX GLR should move these + method nodemap(&block) is nodal { nodemap(&block, self) } + method duckmap(&block) is nodal { duckmap(&block, self) } + method deepmap(&block) is nodal { deepmap(&block, self) } + + # XXX GLR Do we need tree post-GLR? + proto method tree(|) is nodal {*} + multi method tree(Any:U:) { self } + multi method tree(Any:D:) { + nqp::istype(self, Iterable) + ?? self.map({ .tree }).item + !! self + } + multi method tree(Any:D: Whatever ) { self.tree } + multi method tree(Any:D: Int(Cool) $count) { + nqp::istype(self, Iterable) && $count > 0 + ?? self.map({ .tree($count - 1) }).item + !! self + } + multi method tree(Any:D: @ [&first, *@rest]) { self.tree(&first, |@rest); } + multi method tree(Any:D: &first, *@rest) { + nqp::istype(self, Iterable) + ?? @rest ?? first(self.map({ .tree(|@rest) })) + !! first(self) + !! self + } + + # auto-vivifying + proto method push(|) is nodal {*} + multi method push(Any:U \SELF: |values) { + SELF = nqp::istype(SELF,Positional) ?? SELF.new !! Array.new; + SELF.push(|values); + } + + proto method append(|) is nodal {*} + multi method append(Any:U \SELF: |values) { + SELF = nqp::istype(SELF,Positional) ?? SELF.new !! Array.new; + SELF.append(|values); + } + + proto method unshift(|) is nodal {*} + multi method unshift(Any:U \SELF: |values) { + SELF = Array.new; + SELF.unshift(|values); + } + + proto method prepend(|) is nodal {*} + multi method prepend(Any:U \SELF: |values) { + SELF = Array.new; + SELF.prepend(|values); + } + + proto method EXISTS-POS(|) is nodal {*} + multi method EXISTS-POS(Any:U: Any:D $ --> False) { } + multi method EXISTS-POS(Any:U: Any:U $pos) { + die "Cannot use '{$pos.^name}' as an index"; + } + + multi method EXISTS-POS(Any:D: int \pos) { + nqp::p6bool(nqp::iseq_i(pos,0)); + } + multi method EXISTS-POS(Any:D: Int:D \pos) { + pos == 0; + } + multi method EXISTS-POS(Any:D: Num:D \pos) { + X::Item.new(aggregate => self, index => pos).throw + if nqp::isnanorinf(pos); + self.AT-POS(nqp::unbox_i(pos.Int)); + pos == 0; + } + multi method EXISTS-POS(Any:D: Any:D \pos) { + pos.Int == 0; + } + multi method EXISTS-POS(Any:D: Any:U \pos) { + die "Cannot use '{pos.^name}' as an index"; + } + multi method EXISTS-POS(Any:D: \one, \two) is raw { + self.AT-POS(one).EXISTS-POS(two) + } + multi method EXISTS-POS(Any:D: \one, \two,\three) is raw { + self.AT-POS(one).AT-POS(two).EXISTS-POS(three) + } + multi method EXISTS-POS(Any:D: **@indices) { + my $final := @indices.pop; + Rakudo::Internals.WALK-AT-POS(self,@indices).EXISTS-POS($final) + } + + proto method AT-POS(|) is nodal {*} + multi method AT-POS(Any:U \SELF: int \pos) is raw { + nqp::p6bindattrinvres( + my $scalar, + Scalar, + '$!whence', + -> { nqp::if( + nqp::isconcrete(SELF), + SELF, + (SELF = Array.new) + ).BIND-POS(pos, $scalar) + } + ) + } + multi method AT-POS(Any:U \SELF: Int:D \pos) is raw { + nqp::p6bindattrinvres( + my $scalar, + Scalar, + '$!whence', + -> { nqp::if( + nqp::isconcrete(SELF), + SELF, + (SELF = Array.new) + ).BIND-POS(pos, $scalar) + } + ) + } + multi method AT-POS(Any:U: Num:D \pos) is raw { + nqp::isnanorinf(pos) + ?? Failure.new(X::Item.new(aggregate => self, index => pos)) + !! self.AT-POS(nqp::unbox_i(pos.Int)) + } + multi method AT-POS(Any:U: Any:D \pos) is raw { + self.AT-POS(nqp::unbox_i(pos.Int)); + } + + multi method AT-POS(Any:D: int \pos) is raw { + pos + ?? Failure.new(X::OutOfRange.new( + :what($*INDEX // 'Index'), :got(pos), :range<0..0>)) + !! self + } + multi method AT-POS(Any:D: Int:D \pos) is raw { + pos + ?? Failure.new(X::OutOfRange.new( + :what($*INDEX // 'Index'), :got(pos), :range<0..0>)) + !! self + } + multi method AT-POS(Any:D: Num:D \pos) is raw { + nqp::isnanorinf(pos) + ?? Failure.new(X::Item.new(aggregate => self, index => pos)) + !! self.AT-POS(nqp::unbox_i(pos.Int)) + } + multi method AT-POS(Any:D: Any:D \pos) is raw { + self.AT-POS(nqp::unbox_i(pos.Int)); + } + multi method AT-POS(Any: Any:U \pos) is raw { + die "Cannot use '{pos.^name}' as an index"; + } + multi method AT-POS(Any:D: \one, \two) is raw { + self.AT-POS(one).AT-POS(two) + } + multi method AT-POS(Any:D: \one, \two, \three) is raw { + self.AT-POS(one).AT-POS(two).AT-POS(three) + } + multi method AT-POS(Any:D: **@indices) is raw { + my $final := @indices.pop; + Rakudo::Internals.WALK-AT-POS(self,@indices).AT-POS($final) + } + + proto method ZEN-POS(|) {*} + multi method ZEN-POS(*%unexpected) { + %unexpected + ?? Failure.new(X::Adverb.new( + :what('[] slice'), + :source(try { self.VAR.name } // self.WHAT.perl), + :unexpected(%unexpected.keys))) + !! self + } + + proto method ZEN-KEY(|) {*} + multi method ZEN-KEY(*%unexpected) { + %unexpected + ?? Failure.new(X::Adverb.new( + :what('{} slice'), + :source(try { self.VAR.name } // self.WHAT.perl), + :unexpected(%unexpected.keys))) + !! self + } + + proto method ASSIGN-POS(|) is nodal {*} + multi method ASSIGN-POS(Any:U \SELF: \pos, Mu \assignee) { + SELF.AT-POS(pos) = assignee; # defer < 0 check + } + + multi method ASSIGN-POS(Any:D: int \pos, Mu \assignee) { + self.AT-POS(pos) = assignee; # defer < 0 check + } + multi method ASSIGN-POS(Any:D: Int:D \pos, Mu \assignee) { + self.AT-POS(pos) = assignee; # defer < 0 check + } + multi method ASSIGN-POS(Any:D: Num:D \pos, Mu \assignee) { + nqp::isnanorinf(pos) + ?? Failure.new(X::Item.new(aggregate => self, index => pos)) + !! self.AT-POS(nqp::unbox_i(pos.Int)) = assignee; # defer < 0 check + } + multi method ASSIGN-POS(Any:D: Any:D \pos, Mu \assignee) { + self.AT-POS(nqp::unbox_i(pos.Int)) = assignee; # defer < 0 check + } + multi method ASSIGN-POS(Any:D: Any:U \pos, Mu \assignee) { + die "Cannot use '{pos.^name}' as an index"; + } + multi method ASSIGN-POS(Any:D: \one, \two, Mu \assignee) is raw { + self.AT-POS(one).ASSIGN-POS(two, assignee) + } + multi method ASSIGN-POS(Any:D: \one, \two, \three, Mu \assignee) is raw { + self.AT-POS(one).AT-POS(two).ASSIGN-POS(three, assignee) + } + multi method ASSIGN-POS(Any:D: **@indices) { + my \value := @indices.pop; + my $final := @indices.pop; + Rakudo::Internals.WALK-AT-POS(self,@indices).ASSIGN-POS($final,value) + } + + proto method BIND-POS(|) {*} + multi method BIND-POS(Any:D: **@indices is raw) is raw { +# looks like Array.pop doesn't really return a bindable container +# my \value := @indices.pop; +# my $final := @indices.pop; +# Rakudo::Internals.WALK-AT-POS(self,@indices).BIND-POS($final,value) + + my int $elems = @indices.elems; # reifies + my \value := @indices.AT-POS(--$elems); + my $final := @indices.AT-POS(--$elems); + my $target := self; + my int $i = -1; + $target := $target.AT-POS(@indices.AT-POS($i)) + while nqp::islt_i(++$i,$elems); + X::Bind.new.throw if $target =:= self; + $target.BIND-POS($final, value) + } + + method all() is nodal { Junction.new("all", self) } + method any() is nodal { Junction.new("any", self) } + method one() is nodal { Junction.new("one", self) } + method none() is nodal { Junction.new("none",self) } + + # internals + proto method AT-KEY(|) is nodal {*} + multi method AT-KEY(Any:D: $key) is raw { + Failure.new( self ~~ Associative + ?? "Associative indexing implementation missing from type {self.WHAT.perl}" + !! "Type {self.WHAT.perl} does not support associative indexing." + ) + } + multi method AT-KEY(Any:U \SELF: \key) is raw { + nqp::p6bindattrinvres( + my $scalar, + Scalar, + '$!whence', + # NOTE: even though the signature indicates a non-concrete SELF, + # by the time the below code is executed, it *may* have become + # concrete: and then we don't want the execution to reset it to + # an empty Hash. + -> { nqp::if( + nqp::isconcrete(SELF), + SELF, + (SELF = nqp::create(Hash)) + ).BIND-KEY(key, $scalar) + } + ) + } + + proto method BIND-KEY(|) is nodal {*} + multi method BIND-KEY(Any:D: \k, \v) is raw { + X::Bind.new(target => self.^name).throw + } + multi method BIND-KEY(Any:U \SELF: $key, $BIND ) is raw { + SELF = Hash.new; + SELF.BIND-KEY($key, $BIND); + $BIND + } + + proto method ASSIGN-KEY(|) is nodal {*} + multi method ASSIGN-KEY(\SELF: \key, Mu \assignee) is raw { + SELF.AT-KEY(key) = assignee; + } + + # XXX GLR review these + method FLATTENABLE_LIST() is nodal { + my $list := self.list; + nqp::findmethod($list, 'FLATTENABLE_LIST')($list); + } + method FLATTENABLE_HASH() is nodal { nqp::hash() } + + proto method Set(|) is nodal {*} + multi method Set(Any:) { Set.new-from-pairs(self.list) } + + proto method SetHash(|) is nodal {*} + multi method SetHash(Any:) { SetHash.new-from-pairs(self.list) } + + proto method Bag(|) is nodal {*} + multi method Bag(Any:) { Bag.new-from-pairs(self.list) } + + proto method BagHash(|) is nodal {*} + multi method BagHash(Any:) { BagHash.new-from-pairs(self.list) } + + proto method Mix(|) is nodal {*} + multi method Mix(Any:) { Mix.new-from-pairs(self.list) } + + proto method MixHash(|) is nodal {*} + multi method MixHash() { MixHash.new-from-pairs(self.list) } + + # XXX GLR does this really need to force a list? + proto method Supply(|) is nodal {*} + multi method Supply() { self.list.Supply } + + method nl-out() { "\n" } + method print-nl() { self.print(self.nl-out) } + + method lazy-if($flag) { self } # no-op on non-Iterables + + method sum() is nodal { + my \iter = self.iterator; + my $sum = 0; + my Mu $value; + nqp::until( + nqp::eqaddr(($value := iter.pull-one),IterationEnd), + ($sum = $sum + $value) + ); + $sum; + } +} +Metamodel::ClassHOW.exclude_parent(Any); + +# builtin ops +proto sub infix:<===>(Mu $?, Mu $?) is pure {*} +multi sub infix:<===>($?) { Bool::True } +multi sub infix:<===>(\a, \b) { + nqp::p6bool( + nqp::eqaddr(nqp::decont(a),nqp::decont(b)) + || (nqp::eqaddr(a.WHAT,b.WHAT) + && nqp::iseq_s(nqp::unbox_s(a.WHICH), nqp::unbox_s(b.WHICH))) + ) +} + +proto sub infix:(Mu $?, Mu $?) is pure {*} +multi sub infix:($?) { Bool::True } +multi sub infix:(\a, \b) { (a cmp b) < 0 } + +proto sub infix:(Mu $?, Mu $?) is pure {*} +multi sub infix:($x?) { Bool::True } +multi sub infix:(\a, \b) { (a cmp b) > 0 } + +proto prefix:<++>(Mu) {*} +multi prefix:<++>(Mu:D $a is rw) { $a = $a.succ } +multi prefix:<++>(Mu:U $a is rw) { $a = 1 } +proto prefix:<-->(Mu) {*} +multi prefix:<-->(Mu:D $a is rw) { $a = $a.pred } +multi prefix:<-->(Mu:U $a is rw) { $a = -1 } + +proto postfix:<++>(Mu) {*} +multi postfix:<++>(Mu:D $a is rw) { my $b = $a; $a = $a.succ; $b } +multi postfix:<++>(Mu:U $a is rw) { $a = 1; 0 } +proto postfix:<-->(Mu) {*} +multi postfix:<-->(Mu:D $a is rw) { my $b = $a; $a = $a.pred; $b } +multi postfix:<-->(Mu:U $a is rw) { $a = -1; 0 } + +proto sub pick(|) {*} +multi sub pick($n, +values) { values.pick($n) } + +proto sub roll(|) {*} +multi sub roll($n, +values) { values.roll($n) } + +proto sub keys(|) {*} +multi sub keys($x) { $x.keys } + +proto sub values(|) {*} +multi sub values($x) { $x.values } + +proto sub pairs(|) {*} +multi sub pairs($x) { $x.pairs } + +proto sub kv(|) {*} +multi sub kv($x) { $x.kv } + +proto sub elems(|) is nodal {*} +multi sub elems($a) { $a.elems } + +proto sub end(|) {*} +multi sub end($a) { $a.end } + +proto sub sum(|) {*} +multi sub sum() { 0 } +multi sub sum(\SELF) { SELF.sum } +multi sub sum(+SELF) { SELF.sum } + +proto sub classify(|) {*} +multi sub classify($test, +items, :$into!, *%named ) { + ( $into // $into.new).classify-list($test, items, |%named) +} +multi sub classify($test, +items, *%named ) { + Hash.^parameterize(Any,Any).new.classify-list($test, items, |%named); +} + +proto sub categorize(|) {*} +multi sub categorize($test, +items, :$into!, *%named ) { + ( $into // $into.new).categorize-list($test, items, |%named) +} +multi sub categorize($test, +items, *%named ) { + Hash.^parameterize(Any,Any).new.categorize-list($test, items, |%named) +} + +proto sub item(|) is pure {*} +multi sub item(\x) { my $ = x } +multi sub item(|c) { my $ = c.list } +multi sub item(Mu $a) { $a } + +sub SLICE_HUH(\SELF, @nogo, %d, %adv) { + @nogo.unshift('delete') # recover any :delete if necessary + if @nogo && @nogo[0] ne 'delete' && %adv.EXISTS-KEY('delete'); + for -> $valid { # check all valid params + if nqp::existskey(%d,nqp::unbox_s($valid)) { + nqp::deletekey(%d,nqp::unbox_s($valid)); + @nogo.push($valid); + } + } + + Failure.new(X::Adverb.new( + :what, + :source(try { SELF.VAR.name } // SELF.WHAT.perl), + :unexpected(%d.keys), + :nogo(@nogo), + )) +} #SLICE_HUH + +sub dd(|) { + my Mu $args := nqp::p6argvmarray(); + if nqp::elems($args) { + while $args { + my $var := nqp::shift($args); + my $name := ! nqp::istype($var.VAR, Failure) && try $var.VAR.name; + my $type := $var.WHAT.^name; + my $what := nqp::can($var, 'is-lazy') && $var.is-lazy + ?? $var[^10].perl.chop ~ "... lazy list)" + !! nqp::can($var, 'perl') + ?? $var.perl + !! "($var.^name() without .perl method)"; + note $name ?? "$type $name = $what" !! $what; + } + } + else { # tell where we are + note .name + ?? "{lc .^name} {.name}{.signature.gist}" + !! "{lc .^name} {.signature.gist}" + with callframe(1).code; + } + return +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Argfiles.pm rakudo-2018.03/src/core/Argfiles.pm --- rakudo-2018.02.1/src/core/Argfiles.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Argfiles.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -Rakudo::Internals.REGISTER-DYNAMIC: '@*ARGS', { - my @ARGS; - my Mu $argiter := nqp::getcurhllsym('$!ARGITER'); - @ARGS.push(nqp::p6box_s(nqp::shift($argiter))) while $argiter; - PROCESS::<@ARGS> := @ARGS; -} -Rakudo::Internals.REGISTER-DYNAMIC: '$*ARGFILES', { - # Here, we use $*IN's attributes to init the arg files because - # the $*ARGFILES won't get instantiated until first access and by that - # time the user may have already modified $*IN's attributes to their liking - PROCESS::<$ARGFILES> = @*ARGS - ?? IO::ArgFiles.new(@*ARGS) - !! IO::ArgFiles.new: - (my $in := $*IN), - :nl-in($in.nl-in), :chomp($in.chomp), :encoding($in.encoding), - :bin(nqp::p6bool(nqp::isfalse($in.encoding))); -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Argfiles.pm6 rakudo-2018.03/src/core/Argfiles.pm6 --- rakudo-2018.02.1/src/core/Argfiles.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Argfiles.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,19 @@ +Rakudo::Internals.REGISTER-DYNAMIC: '@*ARGS', { + my @ARGS; + my Mu $argiter := nqp::getcurhllsym('$!ARGITER'); + @ARGS.push(nqp::p6box_s(nqp::shift($argiter))) while $argiter; + PROCESS::<@ARGS> := @ARGS; +} +Rakudo::Internals.REGISTER-DYNAMIC: '$*ARGFILES', { + # Here, we use $*IN's attributes to init the arg files because + # the $*ARGFILES won't get instantiated until first access and by that + # time the user may have already modified $*IN's attributes to their liking + PROCESS::<$ARGFILES> = @*ARGS + ?? IO::ArgFiles.new(@*ARGS) + !! IO::ArgFiles.new: + (my $in := $*IN), + :nl-in($in.nl-in), :chomp($in.chomp), :encoding($in.encoding), + :bin(nqp::p6bool(nqp::isfalse($in.encoding))); +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/array_operators.pm rakudo-2018.03/src/core/array_operators.pm --- rakudo-2018.02.1/src/core/array_operators.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/array_operators.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,69 +0,0 @@ -# The [...] term creates an Array. -proto circumfix:<[ ]>(|) {*} -multi circumfix:<[ ]>() { - nqp::create(Array) -} -multi circumfix:<[ ]>(Iterable:D \iterable) { - my $reified; - nqp::if( - nqp::iscont(iterable), - nqp::p6bindattrinvres( - nqp::create(Array),List,'$!reified', - nqp::stmts( - nqp::push( - ($reified := nqp::create(IterationBuffer)), - nqp::assign(nqp::p6scalarfromdesc(nqp::null),iterable) - ), - $reified - ) - ), - nqp::if( - nqp::eqaddr(iterable.WHAT,List), - nqp::if( - iterable.is-lazy, - Array.from-iterator(iterable.iterator), - nqp::stmts( # immutable List - (my int $elems = iterable.elems), # reifies - (my $params := nqp::getattr(iterable,List,'$!reified')), - (my int $i = -1), - ($reified := nqp::setelems(nqp::create(IterationBuffer),$elems)), - nqp::while( - nqp::islt_i(($i = nqp::add_i($i,1)),$elems), - nqp::bindpos($reified,$i,nqp::assign( - nqp::p6scalarfromdesc(nqp::null),nqp::atpos($params,$i)) - ) - ), - nqp::p6bindattrinvres(nqp::create(Array),List,'$!reified',$reified) - ), - ), - Array.from-iterator(iterable.iterator) - ) - ) -} -multi circumfix:<[ ]>(Mu \x) { # really only for [$foo] - nqp::p6bindattrinvres( - nqp::create(Array),List,'$!reified', - nqp::stmts( - nqp::push( - (my $reified := nqp::create(IterationBuffer)), - nqp::assign(nqp::p6scalarfromdesc(nqp::null),x) - ), - $reified - ) - ) -} - -proto sub pop(@) {*} -multi sub pop(@a) { @a.pop } - -proto sub shift(@) {*} -multi sub shift(@a) { @a.shift } - -sub push (\a, |elems) { a.push: |elems } -sub append (\a, |elems) { a.append: |elems } -sub unshift(\a, |elems) { a.unshift: |elems } -sub prepend(\a, |elems) { a.prepend: |elems } - -sub splice(@arr, |c) { @arr.splice(|c) } - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/array_operators.pm6 rakudo-2018.03/src/core/array_operators.pm6 --- rakudo-2018.02.1/src/core/array_operators.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/array_operators.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,77 @@ +# The [...] term creates an Array. +proto circumfix:<[ ]>(|) {*} +multi circumfix:<[ ]>() { + nqp::create(Array) +} +multi circumfix:<[ ]>(Iterable:D \iterable) { + my $reified; + nqp::if( + nqp::iscont(iterable), + nqp::p6bindattrinvres( + nqp::create(Array),List,'$!reified', + nqp::stmts( + nqp::push( + ($reified := nqp::create(IterationBuffer)), + nqp::assign(nqp::p6scalarfromdesc(nqp::null),iterable) + ), + $reified + ) + ), + nqp::if( + nqp::eqaddr(iterable.WHAT,List), + nqp::if( + iterable.is-lazy, + Array.from-iterator(iterable.iterator), + nqp::stmts( # immutable List + (my int $elems = iterable.elems), # reifies + (my $params := nqp::getattr(iterable,List,'$!reified')), + (my int $i = -1), + ($reified := nqp::setelems(nqp::create(IterationBuffer),$elems)), + nqp::while( + nqp::islt_i(($i = nqp::add_i($i,1)),$elems), + nqp::bindpos($reified,$i,nqp::assign( + nqp::p6scalarfromdesc(nqp::null),nqp::atpos($params,$i)) + ) + ), + nqp::p6bindattrinvres(nqp::create(Array),List,'$!reified',$reified) + ), + ), + Array.from-iterator(iterable.iterator) + ) + ) +} +multi circumfix:<[ ]>(Mu \x) { # really only for [$foo] + nqp::p6bindattrinvres( + nqp::create(Array),List,'$!reified', + nqp::stmts( + nqp::push( + (my $reified := nqp::create(IterationBuffer)), + nqp::assign(nqp::p6scalarfromdesc(nqp::null),x) + ), + $reified + ) + ) +} + +proto sub pop(@) {*} +multi sub pop(@a) { @a.pop } + +proto sub shift(@) {*} +multi sub shift(@a) { @a.shift } + +proto sub push(|) {*} +multi sub push(\a, |elems) { a.push: |elems } + +proto sub append(|) {*} +multi sub append(\a, |elems) { a.append: |elems } + +proto sub unshift(|) {*} +multi sub unshift(\a, |elems) { a.unshift: |elems } + +proto sub prepend(|) {*} +multi sub prepend(\a, |elems) { a.prepend: |elems } + +proto sub splice(|) {*} +multi sub splice(@arr, |c) { @arr.splice(|c) } + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Array.pm rakudo-2018.03/src/core/Array.pm --- rakudo-2018.02.1/src/core/Array.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Array.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,1237 +0,0 @@ -# for our tantrums -my class X::TypeCheck { ... }; -my class X::TypeCheck::Splice { ... } -my class X::Subscript::Negative { ... }; -my class X::NotEnoughDimensions { ... }; -my class X::Assignment::ArrayShapeMismatch { ... }; - -# stub what we need now -my class array is repr('VMArray') { ... }; - -# An Array is a List that ensures every item added to it is in a Scalar -# container. It also supports push, pop, shift, unshift, splice, BIND-POS, -# and so forth. -my class Array { # declared in BOOTSTRAP - # class Array is List - # has Mu $!descriptor; - - my class ArrayReificationTarget { - has $!target; - has $!descriptor; - - method new(\target, Mu \descriptor) { - nqp::stmts( - nqp::bindattr((my \rt = nqp::create(self)), - self,'$!target',target), - nqp::p6bindattrinvres(rt, - self,'$!descriptor',descriptor) - ) - } - - method push(Mu \value) { - nqp::push($!target, - nqp::assign(nqp::p6scalarfromdesc($!descriptor), value)); - } - } - - my class ListReificationTarget { - has $!target; - - method new(\target) { - nqp::p6bindattrinvres(nqp::create(self), self, '$!target', target); - } - - method push(Mu \value) { - nqp::push($!target, - nqp::decont(value)); - } - } - - multi method clone(Array:D:) { - nqp::stmts( - (my \iter := self.iterator), - (my \result := nqp::p6bindattrinvres(nqp::create(self), - Array, '$!descriptor', nqp::isnull($!descriptor) ?? (nqp::null) !! nqp::clone($!descriptor))), - nqp::if( - nqp::eqaddr( - IterationEnd, - iter.push-until-lazy: - my \target := ArrayReificationTarget.new( - (my \buffer := nqp::create(IterationBuffer)), - nqp::isnull($!descriptor) ?? (nqp::null) !! nqp::clone($!descriptor))), - nqp::p6bindattrinvres(result, List, '$!reified', buffer), - nqp::stmts( - nqp::bindattr(result, List, '$!reified', buffer), - nqp::bindattr((my \todo := nqp::create(List::Reifier)), - List::Reifier,'$!current-iter', iter), - nqp::bindattr(todo, - List::Reifier,'$!reified', buffer), - nqp::bindattr(todo, - List::Reifier,'$!reification-target', target), - nqp::p6bindattrinvres(result, List, '$!todo', todo)))) - } - - method iterator(Array:D:) { - - # something to iterate over in the future - if nqp::getattr(self,List,'$!todo').DEFINITE { - class :: does Iterator { - has int $!i; - has $!array; - has $!reified; - has $!todo; - has $!descriptor; - - method !SET-SELF(\array) { - $!i = -1; - $!array := array; - $!reified := - nqp::ifnull( - nqp::getattr( array,List,'$!reified'), - nqp::bindattr(array,List,'$!reified', - nqp::create(IterationBuffer)) - ); - $!todo := nqp::getattr(array,List, '$!todo'); - $!descriptor := nqp::getattr(array,Array,'$!descriptor'); - self - } - method new(\array) { nqp::create(self)!SET-SELF(array) } - - method pull-one() is raw { - nqp::ifnull( - nqp::atpos($!reified,$!i = nqp::add_i($!i,1)), - nqp::islt_i($!i,nqp::elems($!reified)) - ?? self!hole($!i) - !! $!todo.DEFINITE - ?? nqp::islt_i($!i,$!todo.reify-at-least(nqp::add_i($!i,1))) - ?? nqp::atpos($!reified,$!i) # cannot be nqp::null - !! self!done - !! IterationEnd - ) - } - method !hole(int $i) { - nqp::p6bindattrinvres( - (my \v := nqp::p6scalarfromdesc($!descriptor)), - Scalar, - '$!whence', - -> { nqp::bindpos($!reified,$i,v) } - ) - } - method !done() is raw { - $!todo := nqp::bindattr($!array,List,'$!todo',Mu); - IterationEnd - } - - method push-until-lazy($target) { - nqp::if( - nqp::isconcrete($!todo), - nqp::stmts( - (my int $elems = $!todo.reify-until-lazy), - (my int $i = $!i), # lexicals faster than attributes - nqp::while( # doesn't sink - nqp::islt_i($i = nqp::add_i($i,1),$elems), - $target.push(nqp::atpos($!reified,$i)) - ), - nqp::if( - $!todo.fully-reified, - nqp::stmts( - ($!i = $i), - self!done - ), - nqp::stmts( - ($!i = nqp::sub_i($elems,1)), - Mu - ) - ) - ), - nqp::stmts( - ($elems = nqp::elems($!reified)), - ($i = $!i), - nqp::while( # doesn't sink - nqp::islt_i($i = nqp::add_i($i,1),$elems), - $target.push( - nqp::ifnull(nqp::atpos($!reified,$i),self!hole($i)) - ) - ), - ($!i = $i), - IterationEnd - ) - ) - } - - method is-lazy() { $!todo.DEFINITE && $!todo.is-lazy } - }.new(self) - } - - # everything we need is already there - elsif nqp::getattr(self,List,'$!reified').DEFINITE { - Rakudo::Iterator.ReifiedArray( - self, - nqp::getattr(self,Array,'$!descriptor') - ) - } - - # nothing now or in the future to iterate over - else { - Rakudo::Iterator.Empty - } - } - method from-iterator(Array:U: Iterator $iter) { - nqp::if( - nqp::eqaddr( - $iter.push-until-lazy( - my \target := ArrayReificationTarget.new( - (my \buffer := nqp::create(IterationBuffer)), - nqp::null - ) - ), - IterationEnd - ), - nqp::p6bindattrinvres(nqp::create(self),List,'$!reified',buffer), - nqp::stmts( - nqp::bindattr((my \result := nqp::create(self)), - List,'$!reified',buffer), - nqp::bindattr((my \todo := nqp::create(List::Reifier)), - List::Reifier,'$!current-iter',$iter), - nqp::bindattr(todo, - List::Reifier,'$!reified',buffer), - nqp::bindattr(todo, - List::Reifier,'$!reification-target',target), - nqp::p6bindattrinvres(result,List,'$!todo',todo) - ) - ) - } - - proto method new(|) {*} - multi method new(:$shape!) { - nqp::if( - nqp::defined($shape), - set-shape(self,$shape), - nqp::if( - Metamodel::EnumHOW.ACCEPTS($shape.HOW), - set-shape(self,$shape.^elems), - nqp::create(self) - ) - ) - } - multi method new() { - nqp::create(self) - } - multi method new(\values, :$shape!) { - nqp::if( - nqp::defined($shape), - set-shape(self,$shape), - nqp::if( - Metamodel::EnumHOW.ACCEPTS($shape.HOW), - set-shape(self,$shape.^elems), - nqp::create(self) - ) - ).STORE(values) - } - multi method new(\values) { - nqp::create(self).STORE(values) - } - multi method new(**@values is raw, :$shape!) { - nqp::if( - nqp::defined($shape), - set-shape(self,$shape), - nqp::if( - Metamodel::EnumHOW.ACCEPTS($shape.HOW), - set-shape(self,$shape.^elems), - nqp::create(self) - ) - ).STORE(@values) - } - multi method new(**@values is raw) { - nqp::create(self).STORE(@values) - } - - proto method STORE(|) {*} - multi method STORE(Array:D: Iterable:D \iterable) { - nqp::iscont(iterable) - ?? self!STORE-ONE(iterable) - !! self!STORE-ITERABLE(iterable) - } - multi method STORE(Array:D: Mu \item) { - self!STORE-ONE(item) - } - method !STORE-ITERABLE(\iterable) { - my \new-storage = nqp::create(IterationBuffer); - my \iter = iterable.iterator; - my \target = ArrayReificationTarget.new(new-storage, - nqp::decont($!descriptor)); - if iter.push-until-lazy(target) =:= IterationEnd { - nqp::bindattr(self, List, '$!todo', Mu); - } - else { - my \new-todo = nqp::create(List::Reifier); - nqp::bindattr(new-todo, List::Reifier, '$!reified', new-storage); - nqp::bindattr(new-todo, List::Reifier, '$!current-iter', iter); - nqp::bindattr(new-todo, List::Reifier, '$!reification-target', target); - nqp::bindattr(self, List, '$!todo', new-todo); - } - nqp::bindattr(self, List, '$!reified', new-storage); - self - } - method !STORE-ONE(Mu \item) { - my \new-storage = nqp::create(IterationBuffer); - nqp::push(new-storage, - nqp::assign(nqp::p6scalarfromdesc($!descriptor), item)); - nqp::bindattr(self, List, '$!reified', new-storage); - nqp::bindattr(self, List, '$!todo', Mu); - self - } - - method reification-target() { - ArrayReificationTarget.new( - nqp::getattr(self, List, '$!reified'), - nqp::decont($!descriptor)) - } - - multi method Slip(Array:D:) { - - # A Slip-With-Default is a special kind of Slip that also has a - # descriptor to be able to generate containers for null elements that - # have type and default information. - my class Slip-With-Descriptor is Slip { - has $!descriptor; - - method iterator() { - Rakudo::Iterator.ReifiedArray(self,$!descriptor) - } - - method !AT-POS-CONTAINER(Int:D \pos) { - nqp::p6bindattrinvres( - (my $scalar := nqp::p6scalarfromdesc($!descriptor)), - Scalar, - '$!whence', - -> { nqp::bindpos( - nqp::getattr(self,List,'$!reified'),pos,$scalar) } - ) - } - - multi method AT-POS(Int:D \pos) { - nqp::ifnull( - nqp::atpos(nqp::getattr(self,List,'$!reified'),pos), - self!AT-POS-CONTAINER(pos) - ) - } - method default() { $!descriptor.default } - } - BEGIN Slip-With-Descriptor.^set_name("Slip"); - - nqp::if( - nqp::getattr(self,List,'$!todo').DEFINITE, - # We're not fully reified, and so have internal mutability still. - # The safe thing to do is to take an iterator of ourself and build - # the Slip out of that. - Slip.from-iterator(self.iterator), - # We're fully reified. Make a Slip that shares our reified buffer - # but that will fill in default values for nulls. - nqp::if( - nqp::getattr(self,List,'$!reified').DEFINITE, - nqp::p6bindattrinvres( - nqp::p6bindattrinvres( - nqp::create(Slip-With-Descriptor), - Slip-With-Descriptor, - '$!descriptor', - $!descriptor - ), - List, - '$!reified', - nqp::getattr(self,List,'$!reified') - ), - nqp::create(Slip) - ) - ) - } - - method FLATTENABLE_LIST() { - nqp::if( - nqp::getattr(self,List,'$!todo').DEFINITE, - nqp::stmts( - nqp::getattr(self,List,'$!todo').reify-all, - nqp::getattr(self,List,'$!reified') - ), - nqp::if( - (my $reified := nqp::getattr(self,List,'$!reified')).DEFINITE, - nqp::stmts( - nqp::if( - (my int $elems = nqp::elems($reified)), - nqp::stmts( - (my int $i = -1), - nqp::while( - nqp::islt_i(($i = nqp::add_i($i,1)),$elems), - nqp::if( - nqp::isnull(nqp::atpos($reified,$i)), - nqp::bindpos( - $reified, - $i, - nqp::p6scalarfromdesc($!descriptor) - ) - ) - ) - ) - ), - nqp::getattr(self,List,'$!reified') - ), - nqp::bindattr(self,List,'$!reified',nqp::create(IterationBuffer)) - ) - ) - } - - multi method flat(Array:U:) { self } - multi method flat(Array:D:) { Seq.new(self.iterator) } - - multi method List(Array:D: :$view) { - nqp::if( - self.is-lazy, # can't make a List - X::Cannot::Lazy.new(:action).throw, - - nqp::if( # all reified - (my $reified := nqp::getattr(self,List,'$!reified')).DEFINITE, - nqp::if( - $view, # assume no change in array - nqp::p6bindattrinvres( - nqp::create(List),List,'$!reified',$reified), - nqp::stmts( # make cow copy - (my int $elems = nqp::elems($reified)), - (my $cow := nqp::setelems(nqp::create(IterationBuffer),$elems)), - (my int $i = -1), - nqp::while( - nqp::islt_i(($i = nqp::add_i($i,1)),$elems), - nqp::bindpos($cow,$i,nqp::ifnull(nqp::decont(nqp::atpos($reified,$i)),Nil)), - ), - nqp::p6bindattrinvres(nqp::create(List),List,'$!reified',$cow) - ) - ), - nqp::create(List) # was empty, is empty - ) - ) - } - - method shape() { (*,) } - - multi method AT-POS(Array:D: int $pos) is raw { - nqp::if( - nqp::isge_i($pos,0) - && nqp::isconcrete(nqp::getattr(self,List,'$!reified')), - nqp::ifnull( - nqp::atpos(nqp::getattr(self,List,'$!reified'),$pos), - self!AT-POS-SLOW($pos) - ), - self!AT-POS-SLOW($pos) - ) - } - # because this is a very hot path, we copied the code from the int candidate - multi method AT-POS(Array:D: Int:D $pos) is raw { - nqp::if( - nqp::isge_i($pos,0) - && nqp::isconcrete(nqp::getattr(self,List,'$!reified')), - nqp::ifnull( - nqp::atpos(nqp::getattr(self,List,'$!reified'),$pos), - self!AT-POS-SLOW($pos) - ), - self!AT-POS-SLOW($pos) - ) - } - - # handle any lookup that's not simple - method !AT-POS-SLOW(\pos) is raw { - nqp::if( - nqp::islt_i(pos, 0), - self!index-oor(pos), - nqp::if( - nqp::isconcrete(my $reified := nqp::getattr(self,List,'$!reified')), - nqp::if( - nqp::islt_i(pos,nqp::elems($reified)), - self!AT-POS-CONTAINER(pos), # it's a hole - nqp::if( # too far out, try reifying - nqp::isconcrete(my $todo := nqp::getattr(self,List,'$!todo')), - nqp::stmts( - $todo.reify-at-least(nqp::add_i(pos,1)), - nqp::ifnull( - nqp::atpos($reified,pos), # reified ok - self!AT-POS-CONTAINER(pos) # reifier didn't reach - ) - ), - self!AT-POS-CONTAINER(pos) # create an outlander - ) - ), - # no reified, implies no todo - nqp::stmts( # create reified - nqp::bindattr(self,List,'$!reified',nqp::create(IterationBuffer)), - self!AT-POS-CONTAINER(pos) # create an outlander - ) - ) - ) - } - method !AT-POS-CONTAINER(int $pos) is raw { - nqp::p6bindattrinvres( - (my $scalar := nqp::p6scalarfromdesc($!descriptor)), - Scalar, - '$!whence', - -> { nqp::bindpos(nqp::getattr(self,List,'$!reified'),$pos,$scalar) } - ) - } - - multi method ASSIGN-POS(Array:D: int $pos, Mu \assignee) { - # Fast path: index > 0, $!reified is set up, either have a container - # or no $!todo so can just bind there - my \reified := nqp::getattr(self,List,'$!reified'); - nqp::if( - nqp::isge_i($pos, 0) && nqp::isconcrete(reified), - nqp::stmts( - (my \target := nqp::atpos(reified, $pos)), - nqp::if( - nqp::isnull(target), - nqp::if( - nqp::isconcrete(nqp::getattr(self, List, '$!todo')), - self!ASSIGN-POS-SLOW-PATH($pos, assignee), - nqp::assign( - nqp::bindpos(reified, $pos, nqp::p6scalarfromdesc($!descriptor)), - assignee - ) - ), - nqp::assign(target, assignee) - ) - ), - self!ASSIGN-POS-SLOW-PATH($pos, assignee) - ) - } - - # because this is a very hot path, we copied the code from the int candidate - multi method ASSIGN-POS(Array:D: Int:D $pos, Mu \assignee) { - # Fast path: index > 0, $!reified is set up, either have a container - # or no $!todo so can just bind there - my \reified := nqp::getattr(self,List,'$!reified'); - my int $ipos = $pos; - nqp::if( - nqp::isge_i($ipos, 0) && nqp::isconcrete(reified), - nqp::stmts( - (my \target := nqp::atpos(reified, $ipos)), - nqp::if( - nqp::isnull(target), - nqp::if( - nqp::isconcrete(nqp::getattr(self, List, '$!todo')), - self!ASSIGN-POS-SLOW-PATH($pos, assignee), - nqp::assign( - nqp::bindpos(reified, $ipos, nqp::p6scalarfromdesc($!descriptor)), - assignee - ) - ), - nqp::assign(target, assignee) - ) - ), - self!ASSIGN-POS-SLOW-PATH($pos, assignee) - ) - } - - method !ASSIGN-POS-SLOW-PATH(Array:D: Int:D $pos, Mu \assignee) { - nqp::if( - nqp::islt_i($pos,0), - self!index-oor($pos), - nqp::if( - nqp::isconcrete(nqp::getattr(self,List,'$!reified')), - nqp::ifnull( - nqp::atpos(nqp::getattr(self,List,'$!reified'),$pos), - nqp::if( - nqp::islt_i( # it's a hole - $pos, - nqp::elems(nqp::getattr(self,List,'$!reified')) - ), - nqp::bindpos( - nqp::getattr(self,List,'$!reified'), - $pos, - nqp::p6scalarfromdesc($!descriptor) - ), - nqp::if( - nqp::isconcrete(nqp::getattr(self,List,'$!todo')), - nqp::stmts( # can reify - nqp::getattr(self,List,'$!todo') - .reify-at-least(nqp::add_i($pos,1)), - nqp::ifnull( - nqp::atpos( # reified - nqp::getattr(self,List,'$!reified'), - $pos - ), - nqp::bindpos( # outlander - nqp::getattr(self,List,'$!reified'), - $pos, - nqp::p6scalarfromdesc($!descriptor) - ) - ) - ), - nqp::bindpos( # outlander without todo - nqp::getattr(self,List,'$!reified'), - $pos, - nqp::p6scalarfromdesc($!descriptor) - ) - ) - ) - ), - nqp::bindpos( # new outlander - nqp::bindattr(self,List,'$!reified',nqp::create(IterationBuffer)), - $pos, - nqp::p6scalarfromdesc($!descriptor) - ) - ) = assignee - ) - } - - multi method BIND-POS(Array:D: int $pos, Mu \bindval) is raw { - nqp::if( - nqp::islt_i($pos,0), - self!index-oor($pos), - nqp::stmts( - nqp::if( - nqp::getattr(self,List,'$!reified').DEFINITE, - nqp::if( - (nqp::isge_i( - $pos,nqp::elems(nqp::getattr(self,List,'$!reified'))) - && nqp::getattr(self,List,'$!todo').DEFINITE), - nqp::getattr(self,List,'$!todo').reify-at-least( - nqp::add_i($pos,1)), - ), - nqp::bindattr(self,List,'$!reified',nqp::create(IterationBuffer)) - ), - nqp::bindpos(nqp::getattr(self,List,'$!reified'),$pos,bindval) - ) - ) - } - # because this is a very hot path, we copied the code from the int candidate - multi method BIND-POS(Array:D: Int:D $pos, Mu \bindval) is raw { - nqp::if( - nqp::islt_i($pos,0), - self!index-oor($pos), - nqp::stmts( - nqp::if( - nqp::getattr(self,List,'$!reified').DEFINITE, - nqp::if( - (nqp::isge_i( - $pos,nqp::elems(nqp::getattr(self,List,'$!reified'))) - && nqp::getattr(self,List,'$!todo').DEFINITE), - nqp::getattr(self,List,'$!todo').reify-at-least( - nqp::add_i($pos,1)), - ), - nqp::bindattr(self,List,'$!reified',nqp::create(IterationBuffer)) - ), - nqp::bindpos(nqp::getattr(self,List,'$!reified'),$pos,bindval) - ) - ) - } - - multi method DELETE-POS(Array:D: int $pos) is raw { - nqp::if( - nqp::islt_i($pos,0), - self!index-oor($pos), - nqp::if( - (my $reified := nqp::getattr(self,List,'$!reified')).DEFINITE, - nqp::stmts( - nqp::if( - (my $todo := nqp::getattr(self,List,'$!todo')).DEFINITE, - $todo.reify-at-least(nqp::add_i($pos,1)), - ), - nqp::if( - nqp::isle_i( # something to delete - $pos,my int $end = nqp::sub_i(nqp::elems($reified),1)), - nqp::stmts( - (my $value := nqp::ifnull( # save the value - nqp::atpos($reified,$pos), - self.default - )), - nqp::bindpos($reified,$pos,nqp::null), # remove this one - nqp::if( - nqp::iseq_i($pos,$end) && nqp::not_i(nqp::defined($todo)), - nqp::stmts( # shorten from end - (my int $i = $pos), - nqp::while( - (nqp::isge_i(($i = nqp::sub_i($i,1)),0) - && nqp::not_i(nqp::existspos($reified,$i))), - nqp::null - ), - nqp::setelems($reified,nqp::add_i($i,1)) - ), - ), - $value # value, if any - ), - self.default # outlander - ), - ), - self.default # no elements - ) - ) - } - multi method DELETE-POS(Array:D: Int:D $pos) is raw { - self.DELETE-POS(nqp::unbox_i($pos)) - } - - method !index-oor($pos) { - Failure.new(X::OutOfRange.new( - :what($*INDEX // 'Index'), :got($pos), :range<0..^Inf> - )) - } - - # MUST have a separate Slip variant to have it slip - multi method push(Array:D: Slip \value) { - self.is-lazy - ?? X::Cannot::Lazy.new(action => 'push to').throw - !! self!append-list(value) - } - multi method push(Array:D: \value) { - nqp::if( - self.is-lazy, - X::Cannot::Lazy.new(action => 'push to').throw, - nqp::stmts( - nqp::push( - nqp::if( - nqp::getattr(self,List,'$!reified').DEFINITE, - nqp::getattr(self,List,'$!reified'), - nqp::bindattr(self,List,'$!reified', - nqp::create(IterationBuffer)) - ), - nqp::assign(nqp::p6scalarfromdesc($!descriptor),value) - ), - self - ) - ) - } - multi method push(Array:D: **@values is raw) { - self.is-lazy - ?? X::Cannot::Lazy.new(action => 'push to').throw - !! self!append-list(@values) - } - - multi method append(Array:D: \value) { - nqp::if( - self.is-lazy, - X::Cannot::Lazy.new(action => 'append to').throw, - nqp::if( - (nqp::iscont(value) || nqp::not_i(nqp::istype(value, Iterable))), - nqp::stmts( - nqp::push( - nqp::if( - nqp::getattr(self,List,'$!reified').DEFINITE, - nqp::getattr(self,List,'$!reified'), - nqp::bindattr(self,List,'$!reified', - nqp::create(IterationBuffer)) - ), - nqp::assign(nqp::p6scalarfromdesc($!descriptor),value) - ), - self - ), - self!append-list(value.list) - ) - ) - } - multi method append(Array:D: **@values is raw) { - self.is-lazy - ?? X::Cannot::Lazy.new(action => 'append to').throw - !! self!append-list(@values) - } - method !append-list(@values) { - nqp::if( - nqp::eqaddr( - @values.iterator.push-until-lazy( - ArrayReificationTarget.new( - nqp::if( - nqp::getattr(self,List,'$!reified').DEFINITE, - nqp::getattr(self,List,'$!reified'), - nqp::bindattr(self,List,'$!reified', - nqp::create(IterationBuffer)) - ), - nqp::decont($!descriptor) - ) - ), - IterationEnd - ), - self, - X::Cannot::Lazy.new(:action,:what(self.^name)).throw - ) - } - - multi method unshift(Array:D: Slip \value) { - self!prepend-list(value) - } - multi method unshift(Array:D: \value) { - nqp::stmts( - nqp::unshift( - nqp::if( - nqp::getattr(self,List,'$!reified').DEFINITE, - nqp::getattr(self,List,'$!reified'), - nqp::bindattr(self,List,'$!reified', - nqp::create(IterationBuffer)) - ), - nqp::assign(nqp::p6scalarfromdesc($!descriptor),value) - ), - self - ) - } - multi method unshift(Array:D: **@values is raw) { - self!prepend-list(@values) - } - multi method prepend(Array:D: \value) { - nqp::if( - (nqp::iscont(value) || nqp::not_i(nqp::istype(value, Iterable))), - nqp::stmts( - nqp::unshift( - nqp::if( - nqp::getattr(self,List,'$!reified').DEFINITE, - nqp::getattr(self,List,'$!reified'), - nqp::bindattr(self,List,'$!reified', - nqp::create(IterationBuffer)) - ), - nqp::assign(nqp::p6scalarfromdesc($!descriptor),value) - ), - self - ), - self!prepend-list(value.list) - ) - } - multi method prepend(Array:D: **@values is raw) { - self!prepend-list(@values) - } - method !prepend-list(@values) { - nqp::stmts( - nqp::if( - nqp::getattr(self,List,'$!reified').DEFINITE, - nqp::splice(nqp::getattr(self,List,'$!reified'), # prepend existing - nqp::stmts( - @values.iterator.push-all( - ArrayReificationTarget.new( - (my $containers := nqp::create(IterationBuffer)), - nqp::decont($!descriptor) - ) - ), - $containers - ), - 0, - 0 - ), - @values.iterator.push-all( # no list yet, make this it - ArrayReificationTarget.new( - nqp::bindattr(self,List,'$!reified', - nqp::create(IterationBuffer)), - nqp::decont($!descriptor) - ) - ) - ), - self - ) - } - - method pop(Array:D:) is raw is nodal { - nqp::if( - self.is-lazy, - Failure.new(X::Cannot::Lazy.new(action => 'pop from')), - nqp::if( - (nqp::getattr(self,List,'$!reified').DEFINITE - && nqp::elems(nqp::getattr(self,List,'$!reified'))), - nqp::pop(nqp::getattr(self,List,'$!reified')), - Failure.new(X::Cannot::Empty.new(:action,:what(self.^name))) - ) - ) - } - - method shift(Array:D:) is raw is nodal { - nqp::if( - nqp::getattr(self,List,'$!reified').DEFINITE - && nqp::elems(nqp::getattr(self,List,'$!reified')), - nqp::ifnull( # handle holes - nqp::shift(nqp::getattr(self,List,'$!reified')), - Nil - ), - nqp::if( - (nqp::getattr(self,List,'$!todo').DEFINITE - && nqp::getattr(self,List,'$!todo').reify-at-least(1)), - nqp::shift(nqp::getattr(self,List,'$!reified')), - Failure.new(X::Cannot::Empty.new(:action,:what(self.^name))) - ) - ) - } - - my $empty := nqp::create(IterationBuffer); # splicing in without values - #------ splice() candidates - multi method splice(Array:D \SELF:) { - nqp::if( - nqp::getattr(SELF,List,'$!reified').DEFINITE, - nqp::stmts( - (my $result := nqp::create(SELF)), - nqp::bindattr($result,Array,'$!descriptor',$!descriptor), - nqp::stmts( # transplant the internals - nqp::bindattr($result,List,'$!reified', - nqp::getattr(SELF,List,'$!reified')), - nqp::if( - nqp::getattr(SELF,List,'$!todo').DEFINITE, - nqp::bindattr($result,List,'$!todo', - nqp::getattr(SELF,List,'$!todo')), - ) - ), - (SELF = nqp::create(SELF)), # XXX this preserves $!descriptor ?? - $result - ), - nqp::p6bindattrinvres( # nothing to return, so create new one - nqp::create(SELF),Array,'$!descriptor',$!descriptor) - ) - } - - #------ splice(offset) candidates - multi method splice(Array:D: Whatever $) { - nqp::p6bindattrinvres( # nothing to return, so create new one - nqp::create(self),Array,'$!descriptor',$!descriptor) - } - multi method splice(Array:D: Callable:D $offset) { - self.splice($offset(self.elems)) - } - multi method splice(Array:D: Int:D $offset) { - nqp::if( - $offset, - nqp::if( - nqp::islt_i(nqp::unbox_i($offset),0), - self!splice-offset-fail($offset), - nqp::if( - (my $todo := nqp::getattr(self,List,'$!todo')).DEFINITE, - nqp::if( - nqp::isge_i( - $todo.reify-at-least($offset),nqp::unbox_i($offset)), - self!splice-offset(nqp::unbox_i($offset)), - self!splice-offset-fail($offset) - ), - nqp::if( - (nqp::getattr(self,List,'$!reified').DEFINITE - && nqp::isge_i( - nqp::elems(nqp::getattr(self,List,'$!reified')), - nqp::unbox_i($offset))), - self!splice-offset(nqp::unbox_i($offset)), - self!splice-offset-fail($offset) - ) - ) - ), - self.splice # offset 0, take the quick route out - ) - } - method !splice-offset(int $offset) { - nqp::stmts( - (my int $elems = nqp::elems(nqp::getattr(self,List,'$!reified'))), - (my int $size = nqp::sub_i($elems,$offset)), - nqp::bindattr((my $result:= nqp::create(self)),List,'$!reified', - (my $buffer := nqp::setelems(nqp::create(IterationBuffer),$size))), - nqp::bindattr($result,Array,'$!descriptor',$!descriptor), - (my int $i = nqp::sub_i($offset,1)), - nqp::while( - nqp::islt_i(($i = nqp::add_i($i,1)),$elems), - nqp::bindpos($buffer,nqp::sub_i($i,$offset), - nqp::atpos(nqp::getattr(self,List,'$!reified'),$i)) - ), - nqp::splice( - nqp::getattr(self,List,'$!reified'),$empty,$offset,$size), - $result - ) - } - method !splice-offset-fail($got) { - X::OutOfRange.new( - :what('Offset argument to splice'), :$got, :range("0..{self.elems}") - ).throw - } - - #------ splice(offset,size) candidates - multi method splice(Array:D: Whatever $, Whatever $) { - nqp::p6bindattrinvres( # nothing to return, so create new one - nqp::create(self),Array,'$!descriptor',$!descriptor) - } - multi method splice(Array:D: Whatever $, Int:D $size) { - self.splice(self.elems,$size) - } - multi method splice(Array:D: Whatever $, Callable:D $size) { - my int $elems = self.elems; - self.splice($elems,$size(nqp::sub_i($elems,$elems))); - } - multi method splice(Array:D: Callable:D $offset, Callable:D $size) { - nqp::stmts( - (my int $elems = self.elems), - (my int $from = $offset($elems)), - self.splice($from,$size(nqp::sub_i($elems,$from))) - ) - } - multi method splice(Array:D: Callable:D $offset, Whatever $) { - self.splice($offset(self.elems)) - } - multi method splice(Array:D: Callable:D $offset, Int:D $size) { - self.splice($offset(self.elems),$size) - } - multi method splice(Array:D: Int:D $offset, Whatever $) { - self.splice($offset) - } - multi method splice(Array:D: Int:D $offset, Callable:D $size) { - self.splice($offset,$size(self.elems - $offset)) - } - multi method splice(Array:D: Int:D $offset, Int:D $size) { - nqp::if( - nqp::islt_i(nqp::unbox_i($offset),0), - self!splice-offset-fail($offset), - nqp::if( - nqp::islt_i(nqp::unbox_i($size),0), - self!splice-size-fail($size,$offset), - nqp::if( - (my $todo := nqp::getattr(self,List,'$!todo')).DEFINITE, - nqp::if( - nqp::isge_i( - $todo.reify-at-least( - nqp::add_i(nqp::unbox_i($offset),nqp::unbox_i($size)) - ),nqp::unbox_i($offset)), - self!splice-offset-size( - nqp::unbox_i($offset),nqp::unbox_i($size)), - self!splice-size-fail($size,$offset) - ), - nqp::if( - nqp::getattr(self,List,'$!reified').DEFINITE, - nqp::if( - nqp::isge_i( - nqp::elems(nqp::getattr(self,List,'$!reified')), - nqp::unbox_i($offset)), - self!splice-offset-size( - nqp::unbox_i($offset),nqp::unbox_i($size)), - self!splice-size-fail($size,$offset) - ), - nqp::if( - nqp::iseq_i(nqp::unbox_i($offset),0), - nqp::p6bindattrinvres( # nothing to return, create new - nqp::create(self),Array,'$!descriptor',$!descriptor), - self!splice-offset-fail($offset) - ) - ) - ) - ) - ) - } - method !splice-offset-size(int $offset,int $size) { - nqp::stmts( - (my $result := self!splice-save($offset,$size,my int $removed)), - nqp::splice( - nqp::getattr(self,List,'$!reified'),$empty,$offset,$removed), - $result - ) - } - method !splice-save(int $offset,int $size, \removed) { - nqp::stmts( - (removed = nqp::if( - nqp::isgt_i( - nqp::add_i($offset,$size), - nqp::elems(nqp::getattr(self,List,'$!reified')) - ), - nqp::sub_i(nqp::elems(nqp::getattr(self,List,'$!reified')),$offset), - $size - )), - nqp::if( - removed, - nqp::stmts( - nqp::bindattr((my $saved:= nqp::create(self)),List,'$!reified', - (my $buffer := - nqp::setelems(nqp::create(IterationBuffer),removed))), - nqp::bindattr($saved,Array,'$!descriptor',$!descriptor), - (my int $i = -1), - nqp::while( - nqp::islt_i(($i = nqp::add_i($i,1)),removed), - nqp::bindpos($buffer,$i,nqp::atpos( - nqp::getattr(self,List,'$!reified'),nqp::add_i($offset,$i))) - ), - $saved - ), - nqp::p6bindattrinvres( # effective size = 0, create new one - nqp::create(self),Array,'$!descriptor',$!descriptor) - ) - ) - } - method !splice-size-fail($got,$offset) { - nqp::if( - $offset > self.elems, - self!splice-offset-fail($offset), - X::OutOfRange.new( - :what('Size argument to splice'), - :$got, - :range("0..^{self.elems - $offset}") - ).throw - ) - } - #------ splice(offset,size,array) candidates - - # we have these 9 multies to avoid infiniloop when incorrect types are - # given to $offset/$size. Other attempts to resolve this showed 30%+ - # performance decreases - multi method splice(Array:D: Whatever $offset, Whatever $size, **@new) { self.splice($offset, $size, @new) } - multi method splice(Array:D: Whatever $offset, Callable:D $size, **@new) { self.splice($offset, $size, @new) } - multi method splice(Array:D: Whatever $offset, Int:D $size, **@new) { self.splice($offset, $size, @new) } - multi method splice(Array:D: Callable:D $offset, Whatever $size, **@new) { self.splice($offset, $size, @new) } - multi method splice(Array:D: Callable:D $offset, Callable:D $size, **@new) { self.splice($offset, $size, @new) } - multi method splice(Array:D: Callable:D $offset, Int:D $size, **@new) { self.splice($offset, $size, @new) } - multi method splice(Array:D: Int:D $offset, Whatever $size, **@new) { self.splice($offset, $size, @new) } - multi method splice(Array:D: Int:D $offset, Callable:D $size, **@new) { self.splice($offset, $size, @new) } - multi method splice(Array:D: Int:D $offset, Int:D $size, **@new) { self.splice($offset, $size, @new) } - - multi method splice(Array:D: Whatever $, Whatever $, @new) { - self.splice(self.elems,0,@new) - } - multi method splice(Array:D: Whatever $, Int:D $size, @new) { - self.splice(self.elems,$size,@new) - } - multi method splice(Array:D: Whatever $, Callable:D $size, @new) { - my int $elems = self.elems; - self.splice($elems,$size(nqp::sub_i($elems,$elems)),@new); - } - multi method splice(Array:D: Callable:D $offset, Callable:D $size, @new) { - nqp::stmts( - (my int $elems = self.elems), - (my int $from = $offset($elems)), - self.splice($from,$size(nqp::sub_i($elems,$from)),@new) - ) - } - multi method splice(Array:D: Callable:D $offset, Whatever $, @new) { - nqp::stmts( - (my int $elems = self.elems), - (my int $from = $offset($elems)), - self.splice($from,nqp::sub_i($elems,$from),@new) - ) - } - multi method splice(Array:D: Callable:D $offset, Int:D $size, @new) { - self.splice($offset(self.elems),$size,@new) - } - multi method splice(Array:D: Int:D $offset, Whatever $, @new) { - self.splice($offset,self.elems - $offset,@new) - } - multi method splice(Array:D: Int:D $offset, Callable:D $size, @new) { - self.splice($offset,$size(self.elems - $offset),@new) - } - multi method splice(Array:D: Int:D $offset, Int:D $size, @new) { - nqp::if( - nqp::islt_i(nqp::unbox_i($offset),0), - self!splice-offset-fail($offset), - nqp::if( - nqp::islt_i(nqp::unbox_i($size),0), - self!splice-size-fail($size,$offset), - nqp::if( - (my $todo := nqp::getattr(self,List,'$!todo')).DEFINITE, - nqp::if( - nqp::isge_i( - $todo.reify-at-least( - nqp::add_i(nqp::unbox_i($offset),nqp::unbox_i($size)) - ),nqp::unbox_i($offset)), - self!splice-offset-size-new( - nqp::unbox_i($offset),nqp::unbox_i($size),@new), - self!splice-size-fail($size,$offset) - ), - nqp::if( - nqp::isge_i( - nqp::elems(nqp::if( - nqp::getattr(self,List,'$!reified').DEFINITE, - nqp::getattr(self,List,'$!reified'), - nqp::bindattr(self,List,'$!reified', - nqp::create(IterationBuffer)) - )), - nqp::unbox_i($offset), - ), - self!splice-offset-size-new( - nqp::unbox_i($offset),nqp::unbox_i($size),@new), - self!splice-offset-fail($offset) - ) - ) - ) - ) - } - method !splice-offset-size-new(int $offset,int $size,@new) { - nqp::if( - nqp::eqaddr(@new.iterator.push-until-lazy( - (my $new := IterationBuffer.new)),IterationEnd), - nqp::if( # reified all values to splice in - (nqp::isnull($!descriptor) || nqp::eqaddr(self.of,Mu)), - nqp::stmts( # no typecheck needed - (my $result := self!splice-save($offset,$size,my int $removed)), - nqp::splice( - nqp::getattr(self,List,'$!reified'),$new,$offset,$removed), - $result - ), - nqp::stmts( # typecheck the values first - (my $expected := self.of), - (my int $elems = nqp::elems($new)), - (my int $i = -1), - nqp::while( - (nqp::islt_i(($i = nqp::add_i($i,1)),$elems) - && nqp::istype(nqp::atpos($new,$i),$expected)), - nqp::null - ), - nqp::if( - nqp::islt_i($i,$elems), # exited loop because of wrong type - X::TypeCheck::Splice.new( - :action, - :got(nqp::atpos($new,$i).WHAT), - :$expected - ).throw, - nqp::stmts( - ($result := self!splice-save($offset,$size,$removed)), - nqp::splice( - nqp::getattr(self,List,'$!reified'),$new,$offset,$removed), - $result - ) - ) - ) - ), - X::Cannot::Lazy.new(:action('splice in')).throw - ) - } - - multi method tail(Array:D: $n) { - nqp::if( - nqp::getattr(self,List,'$!todo').DEFINITE, - self.Any::tail($n), - Seq.new( - nqp::if( - (my $reified := nqp::getattr(self,List,'$!reified')).DEFINITE - && nqp::elems($reified), - nqp::stmts( - (my $iterator := Rakudo::Iterator.ReifiedArray( - self, - nqp::getattr(self,Array,'$!descriptor') - )), - nqp::if( - nqp::istype($n,Callable) - && nqp::isgt_i((my $skip := -($n(0).Int)),0), - $iterator.skip-at-least($skip), - nqp::unless( - nqp::istype($n,Whatever) || $n == Inf, - $iterator.skip-at-least(nqp::elems($reified) - $n) - ) - ), - $iterator - ), - Rakudo::Iterator.Empty - ) - ) - ) - } - - # introspection - method name() { - nqp::isnull($!descriptor) ?? Nil !! $!descriptor.name - } - method of() { - nqp::isnull($!descriptor) ?? Mu !! $!descriptor.of - } - method default() { - nqp::isnull($!descriptor) ?? Any !! $!descriptor.default - } - method dynamic() { - nqp::isnull($!descriptor) ?? False !! so $!descriptor.dynamic - } - multi method perl(Array:D \SELF:) { - SELF.perlseen('Array', { - '$' x nqp::iscont(SELF) # self is always deconted - ~ '[' - ~ self.map({nqp::decont($_).perl}).join(', ') - ~ ',' x (self.elems == 1 && nqp::istype(self.AT-POS(0),Iterable)) - ~ ']' - }) - } - multi method WHICH(Array:D:) { self.Mu::WHICH } - -#=============== class Array is closed in src/core/TypedArray.pm =============== - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Array.pm6 rakudo-2018.03/src/core/Array.pm6 --- rakudo-2018.02.1/src/core/Array.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Array.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,1237 @@ +# for our tantrums +my class X::TypeCheck { ... }; +my class X::TypeCheck::Splice { ... } +my class X::Subscript::Negative { ... }; +my class X::NotEnoughDimensions { ... }; +my class X::Assignment::ArrayShapeMismatch { ... }; + +# stub what we need now +my class array is repr('VMArray') { ... }; + +# An Array is a List that ensures every item added to it is in a Scalar +# container. It also supports push, pop, shift, unshift, splice, BIND-POS, +# and so forth. +my class Array { # declared in BOOTSTRAP + # class Array is List + # has Mu $!descriptor; + + my class ArrayReificationTarget { + has $!target; + has $!descriptor; + + method new(\target, Mu \descriptor) { + nqp::stmts( + nqp::bindattr((my \rt = nqp::create(self)), + self,'$!target',target), + nqp::p6bindattrinvres(rt, + self,'$!descriptor',descriptor) + ) + } + + method push(Mu \value) { + nqp::push($!target, + nqp::assign(nqp::p6scalarfromdesc($!descriptor), value)); + } + } + + my class ListReificationTarget { + has $!target; + + method new(\target) { + nqp::p6bindattrinvres(nqp::create(self), self, '$!target', target); + } + + method push(Mu \value) { + nqp::push($!target, + nqp::decont(value)); + } + } + + multi method clone(Array:D:) { + nqp::stmts( + (my \iter := self.iterator), + (my \result := nqp::p6bindattrinvres(nqp::create(self), + Array, '$!descriptor', nqp::isnull($!descriptor) ?? (nqp::null) !! nqp::clone($!descriptor))), + nqp::if( + nqp::eqaddr( + IterationEnd, + iter.push-until-lazy: + my \target := ArrayReificationTarget.new( + (my \buffer := nqp::create(IterationBuffer)), + nqp::isnull($!descriptor) ?? (nqp::null) !! nqp::clone($!descriptor))), + nqp::p6bindattrinvres(result, List, '$!reified', buffer), + nqp::stmts( + nqp::bindattr(result, List, '$!reified', buffer), + nqp::bindattr((my \todo := nqp::create(List::Reifier)), + List::Reifier,'$!current-iter', iter), + nqp::bindattr(todo, + List::Reifier,'$!reified', buffer), + nqp::bindattr(todo, + List::Reifier,'$!reification-target', target), + nqp::p6bindattrinvres(result, List, '$!todo', todo)))) + } + + method iterator(Array:D:) { + + # something to iterate over in the future + if nqp::getattr(self,List,'$!todo').DEFINITE { + class :: does Iterator { + has int $!i; + has $!array; + has $!reified; + has $!todo; + has $!descriptor; + + method !SET-SELF(\array) { + $!i = -1; + $!array := array; + $!reified := + nqp::ifnull( + nqp::getattr( array,List,'$!reified'), + nqp::bindattr(array,List,'$!reified', + nqp::create(IterationBuffer)) + ); + $!todo := nqp::getattr(array,List, '$!todo'); + $!descriptor := nqp::getattr(array,Array,'$!descriptor'); + self + } + method new(\array) { nqp::create(self)!SET-SELF(array) } + + method pull-one() is raw { + nqp::ifnull( + nqp::atpos($!reified,$!i = nqp::add_i($!i,1)), + nqp::islt_i($!i,nqp::elems($!reified)) + ?? self!hole($!i) + !! $!todo.DEFINITE + ?? nqp::islt_i($!i,$!todo.reify-at-least(nqp::add_i($!i,1))) + ?? nqp::atpos($!reified,$!i) # cannot be nqp::null + !! self!done + !! IterationEnd + ) + } + method !hole(int $i) { + nqp::p6bindattrinvres( + (my \v := nqp::p6scalarfromdesc($!descriptor)), + Scalar, + '$!whence', + -> { nqp::bindpos($!reified,$i,v) } + ) + } + method !done() is raw { + $!todo := nqp::bindattr($!array,List,'$!todo',Mu); + IterationEnd + } + + method push-until-lazy($target) { + nqp::if( + nqp::isconcrete($!todo), + nqp::stmts( + (my int $elems = $!todo.reify-until-lazy), + (my int $i = $!i), # lexicals faster than attributes + nqp::while( # doesn't sink + nqp::islt_i($i = nqp::add_i($i,1),$elems), + $target.push(nqp::atpos($!reified,$i)) + ), + nqp::if( + $!todo.fully-reified, + nqp::stmts( + ($!i = $i), + self!done + ), + nqp::stmts( + ($!i = nqp::sub_i($elems,1)), + Mu + ) + ) + ), + nqp::stmts( + ($elems = nqp::elems($!reified)), + ($i = $!i), + nqp::while( # doesn't sink + nqp::islt_i($i = nqp::add_i($i,1),$elems), + $target.push( + nqp::ifnull(nqp::atpos($!reified,$i),self!hole($i)) + ) + ), + ($!i = $i), + IterationEnd + ) + ) + } + + method is-lazy() { $!todo.DEFINITE && $!todo.is-lazy } + }.new(self) + } + + # everything we need is already there + elsif nqp::getattr(self,List,'$!reified').DEFINITE { + Rakudo::Iterator.ReifiedArray( + self, + nqp::getattr(self,Array,'$!descriptor') + ) + } + + # nothing now or in the future to iterate over + else { + Rakudo::Iterator.Empty + } + } + method from-iterator(Array:U: Iterator $iter) { + nqp::if( + nqp::eqaddr( + $iter.push-until-lazy( + my \target := ArrayReificationTarget.new( + (my \buffer := nqp::create(IterationBuffer)), + nqp::null + ) + ), + IterationEnd + ), + nqp::p6bindattrinvres(nqp::create(self),List,'$!reified',buffer), + nqp::stmts( + nqp::bindattr((my \result := nqp::create(self)), + List,'$!reified',buffer), + nqp::bindattr((my \todo := nqp::create(List::Reifier)), + List::Reifier,'$!current-iter',$iter), + nqp::bindattr(todo, + List::Reifier,'$!reified',buffer), + nqp::bindattr(todo, + List::Reifier,'$!reification-target',target), + nqp::p6bindattrinvres(result,List,'$!todo',todo) + ) + ) + } + + proto method new(|) {*} + multi method new(:$shape!) { + nqp::if( + nqp::defined($shape), + set-shape(self,$shape), + nqp::if( + Metamodel::EnumHOW.ACCEPTS($shape.HOW), + set-shape(self,$shape.^elems), + nqp::create(self) + ) + ) + } + multi method new() { + nqp::create(self) + } + multi method new(\values, :$shape!) { + nqp::if( + nqp::defined($shape), + set-shape(self,$shape), + nqp::if( + Metamodel::EnumHOW.ACCEPTS($shape.HOW), + set-shape(self,$shape.^elems), + nqp::create(self) + ) + ).STORE(values) + } + multi method new(\values) { + nqp::create(self).STORE(values) + } + multi method new(**@values is raw, :$shape!) { + nqp::if( + nqp::defined($shape), + set-shape(self,$shape), + nqp::if( + Metamodel::EnumHOW.ACCEPTS($shape.HOW), + set-shape(self,$shape.^elems), + nqp::create(self) + ) + ).STORE(@values) + } + multi method new(**@values is raw) { + nqp::create(self).STORE(@values) + } + + proto method STORE(|) {*} + multi method STORE(Array:D: Iterable:D \iterable) { + nqp::iscont(iterable) + ?? self!STORE-ONE(iterable) + !! self!STORE-ITERABLE(iterable) + } + multi method STORE(Array:D: Mu \item) { + self!STORE-ONE(item) + } + method !STORE-ITERABLE(\iterable) { + my \new-storage = nqp::create(IterationBuffer); + my \iter = iterable.iterator; + my \target = ArrayReificationTarget.new(new-storage, + nqp::decont($!descriptor)); + if iter.push-until-lazy(target) =:= IterationEnd { + nqp::bindattr(self, List, '$!todo', Mu); + } + else { + my \new-todo = nqp::create(List::Reifier); + nqp::bindattr(new-todo, List::Reifier, '$!reified', new-storage); + nqp::bindattr(new-todo, List::Reifier, '$!current-iter', iter); + nqp::bindattr(new-todo, List::Reifier, '$!reification-target', target); + nqp::bindattr(self, List, '$!todo', new-todo); + } + nqp::bindattr(self, List, '$!reified', new-storage); + self + } + method !STORE-ONE(Mu \item) { + my \new-storage = nqp::create(IterationBuffer); + nqp::push(new-storage, + nqp::assign(nqp::p6scalarfromdesc($!descriptor), item)); + nqp::bindattr(self, List, '$!reified', new-storage); + nqp::bindattr(self, List, '$!todo', Mu); + self + } + + method reification-target() { + ArrayReificationTarget.new( + nqp::getattr(self, List, '$!reified'), + nqp::decont($!descriptor)) + } + + multi method Slip(Array:D:) { + + # A Slip-With-Default is a special kind of Slip that also has a + # descriptor to be able to generate containers for null elements that + # have type and default information. + my class Slip-With-Descriptor is Slip { + has $!descriptor; + + method iterator() { + Rakudo::Iterator.ReifiedArray(self,$!descriptor) + } + + method !AT-POS-CONTAINER(Int:D \pos) { + nqp::p6bindattrinvres( + (my $scalar := nqp::p6scalarfromdesc($!descriptor)), + Scalar, + '$!whence', + -> { nqp::bindpos( + nqp::getattr(self,List,'$!reified'),pos,$scalar) } + ) + } + + multi method AT-POS(Int:D \pos) { + nqp::ifnull( + nqp::atpos(nqp::getattr(self,List,'$!reified'),pos), + self!AT-POS-CONTAINER(pos) + ) + } + method default() { $!descriptor.default } + } + BEGIN Slip-With-Descriptor.^set_name("Slip"); + + nqp::if( + nqp::getattr(self,List,'$!todo').DEFINITE, + # We're not fully reified, and so have internal mutability still. + # The safe thing to do is to take an iterator of ourself and build + # the Slip out of that. + Slip.from-iterator(self.iterator), + # We're fully reified. Make a Slip that shares our reified buffer + # but that will fill in default values for nulls. + nqp::if( + nqp::getattr(self,List,'$!reified').DEFINITE, + nqp::p6bindattrinvres( + nqp::p6bindattrinvres( + nqp::create(Slip-With-Descriptor), + Slip-With-Descriptor, + '$!descriptor', + $!descriptor + ), + List, + '$!reified', + nqp::getattr(self,List,'$!reified') + ), + nqp::create(Slip) + ) + ) + } + + method FLATTENABLE_LIST() { + nqp::if( + nqp::getattr(self,List,'$!todo').DEFINITE, + nqp::stmts( + nqp::getattr(self,List,'$!todo').reify-all, + nqp::getattr(self,List,'$!reified') + ), + nqp::if( + (my $reified := nqp::getattr(self,List,'$!reified')).DEFINITE, + nqp::stmts( + nqp::if( + (my int $elems = nqp::elems($reified)), + nqp::stmts( + (my int $i = -1), + nqp::while( + nqp::islt_i(($i = nqp::add_i($i,1)),$elems), + nqp::if( + nqp::isnull(nqp::atpos($reified,$i)), + nqp::bindpos( + $reified, + $i, + nqp::p6scalarfromdesc($!descriptor) + ) + ) + ) + ) + ), + nqp::getattr(self,List,'$!reified') + ), + nqp::bindattr(self,List,'$!reified',nqp::create(IterationBuffer)) + ) + ) + } + + multi method flat(Array:U:) { self } + multi method flat(Array:D:) { Seq.new(self.iterator) } + + multi method List(Array:D: :$view) { + nqp::if( + self.is-lazy, # can't make a List + X::Cannot::Lazy.new(:action).throw, + + nqp::if( # all reified + (my $reified := nqp::getattr(self,List,'$!reified')).DEFINITE, + nqp::if( + $view, # assume no change in array + nqp::p6bindattrinvres( + nqp::create(List),List,'$!reified',$reified), + nqp::stmts( # make cow copy + (my int $elems = nqp::elems($reified)), + (my $cow := nqp::setelems(nqp::create(IterationBuffer),$elems)), + (my int $i = -1), + nqp::while( + nqp::islt_i(($i = nqp::add_i($i,1)),$elems), + nqp::bindpos($cow,$i,nqp::ifnull(nqp::decont(nqp::atpos($reified,$i)),Nil)), + ), + nqp::p6bindattrinvres(nqp::create(List),List,'$!reified',$cow) + ) + ), + nqp::create(List) # was empty, is empty + ) + ) + } + + method shape() { (*,) } + + multi method AT-POS(Array:D: int $pos) is raw { + nqp::if( + nqp::isge_i($pos,0) + && nqp::isconcrete(nqp::getattr(self,List,'$!reified')), + nqp::ifnull( + nqp::atpos(nqp::getattr(self,List,'$!reified'),$pos), + self!AT-POS-SLOW($pos) + ), + self!AT-POS-SLOW($pos) + ) + } + # because this is a very hot path, we copied the code from the int candidate + multi method AT-POS(Array:D: Int:D $pos) is raw { + nqp::if( + nqp::isge_i($pos,0) + && nqp::isconcrete(nqp::getattr(self,List,'$!reified')), + nqp::ifnull( + nqp::atpos(nqp::getattr(self,List,'$!reified'),$pos), + self!AT-POS-SLOW($pos) + ), + self!AT-POS-SLOW($pos) + ) + } + + # handle any lookup that's not simple + method !AT-POS-SLOW(\pos) is raw { + nqp::if( + nqp::islt_i(pos, 0), + self!index-oor(pos), + nqp::if( + nqp::isconcrete(my $reified := nqp::getattr(self,List,'$!reified')), + nqp::if( + nqp::islt_i(pos,nqp::elems($reified)), + self!AT-POS-CONTAINER(pos), # it's a hole + nqp::if( # too far out, try reifying + nqp::isconcrete(my $todo := nqp::getattr(self,List,'$!todo')), + nqp::stmts( + $todo.reify-at-least(nqp::add_i(pos,1)), + nqp::ifnull( + nqp::atpos($reified,pos), # reified ok + self!AT-POS-CONTAINER(pos) # reifier didn't reach + ) + ), + self!AT-POS-CONTAINER(pos) # create an outlander + ) + ), + # no reified, implies no todo + nqp::stmts( # create reified + nqp::bindattr(self,List,'$!reified',nqp::create(IterationBuffer)), + self!AT-POS-CONTAINER(pos) # create an outlander + ) + ) + ) + } + method !AT-POS-CONTAINER(int $pos) is raw { + nqp::p6bindattrinvres( + (my $scalar := nqp::p6scalarfromdesc($!descriptor)), + Scalar, + '$!whence', + -> { nqp::bindpos(nqp::getattr(self,List,'$!reified'),$pos,$scalar) } + ) + } + + multi method ASSIGN-POS(Array:D: int $pos, Mu \assignee) { + # Fast path: index > 0, $!reified is set up, either have a container + # or no $!todo so can just bind there + my \reified := nqp::getattr(self,List,'$!reified'); + nqp::if( + nqp::isge_i($pos, 0) && nqp::isconcrete(reified), + nqp::stmts( + (my \target := nqp::atpos(reified, $pos)), + nqp::if( + nqp::isnull(target), + nqp::if( + nqp::isconcrete(nqp::getattr(self, List, '$!todo')), + self!ASSIGN-POS-SLOW-PATH($pos, assignee), + nqp::assign( + nqp::bindpos(reified, $pos, nqp::p6scalarfromdesc($!descriptor)), + assignee + ) + ), + nqp::assign(target, assignee) + ) + ), + self!ASSIGN-POS-SLOW-PATH($pos, assignee) + ) + } + + # because this is a very hot path, we copied the code from the int candidate + multi method ASSIGN-POS(Array:D: Int:D $pos, Mu \assignee) { + # Fast path: index > 0, $!reified is set up, either have a container + # or no $!todo so can just bind there + my \reified := nqp::getattr(self,List,'$!reified'); + my int $ipos = $pos; + nqp::if( + nqp::isge_i($ipos, 0) && nqp::isconcrete(reified), + nqp::stmts( + (my \target := nqp::atpos(reified, $ipos)), + nqp::if( + nqp::isnull(target), + nqp::if( + nqp::isconcrete(nqp::getattr(self, List, '$!todo')), + self!ASSIGN-POS-SLOW-PATH($pos, assignee), + nqp::assign( + nqp::bindpos(reified, $ipos, nqp::p6scalarfromdesc($!descriptor)), + assignee + ) + ), + nqp::assign(target, assignee) + ) + ), + self!ASSIGN-POS-SLOW-PATH($pos, assignee) + ) + } + + method !ASSIGN-POS-SLOW-PATH(Array:D: Int:D $pos, Mu \assignee) { + nqp::if( + nqp::islt_i($pos,0), + self!index-oor($pos), + nqp::if( + nqp::isconcrete(nqp::getattr(self,List,'$!reified')), + nqp::ifnull( + nqp::atpos(nqp::getattr(self,List,'$!reified'),$pos), + nqp::if( + nqp::islt_i( # it's a hole + $pos, + nqp::elems(nqp::getattr(self,List,'$!reified')) + ), + nqp::bindpos( + nqp::getattr(self,List,'$!reified'), + $pos, + nqp::p6scalarfromdesc($!descriptor) + ), + nqp::if( + nqp::isconcrete(nqp::getattr(self,List,'$!todo')), + nqp::stmts( # can reify + nqp::getattr(self,List,'$!todo') + .reify-at-least(nqp::add_i($pos,1)), + nqp::ifnull( + nqp::atpos( # reified + nqp::getattr(self,List,'$!reified'), + $pos + ), + nqp::bindpos( # outlander + nqp::getattr(self,List,'$!reified'), + $pos, + nqp::p6scalarfromdesc($!descriptor) + ) + ) + ), + nqp::bindpos( # outlander without todo + nqp::getattr(self,List,'$!reified'), + $pos, + nqp::p6scalarfromdesc($!descriptor) + ) + ) + ) + ), + nqp::bindpos( # new outlander + nqp::bindattr(self,List,'$!reified',nqp::create(IterationBuffer)), + $pos, + nqp::p6scalarfromdesc($!descriptor) + ) + ) = assignee + ) + } + + multi method BIND-POS(Array:D: int $pos, Mu \bindval) is raw { + nqp::if( + nqp::islt_i($pos,0), + self!index-oor($pos), + nqp::stmts( + nqp::if( + nqp::getattr(self,List,'$!reified').DEFINITE, + nqp::if( + (nqp::isge_i( + $pos,nqp::elems(nqp::getattr(self,List,'$!reified'))) + && nqp::getattr(self,List,'$!todo').DEFINITE), + nqp::getattr(self,List,'$!todo').reify-at-least( + nqp::add_i($pos,1)), + ), + nqp::bindattr(self,List,'$!reified',nqp::create(IterationBuffer)) + ), + nqp::bindpos(nqp::getattr(self,List,'$!reified'),$pos,bindval) + ) + ) + } + # because this is a very hot path, we copied the code from the int candidate + multi method BIND-POS(Array:D: Int:D $pos, Mu \bindval) is raw { + nqp::if( + nqp::islt_i($pos,0), + self!index-oor($pos), + nqp::stmts( + nqp::if( + nqp::getattr(self,List,'$!reified').DEFINITE, + nqp::if( + (nqp::isge_i( + $pos,nqp::elems(nqp::getattr(self,List,'$!reified'))) + && nqp::getattr(self,List,'$!todo').DEFINITE), + nqp::getattr(self,List,'$!todo').reify-at-least( + nqp::add_i($pos,1)), + ), + nqp::bindattr(self,List,'$!reified',nqp::create(IterationBuffer)) + ), + nqp::bindpos(nqp::getattr(self,List,'$!reified'),$pos,bindval) + ) + ) + } + + multi method DELETE-POS(Array:D: int $pos) is raw { + nqp::if( + nqp::islt_i($pos,0), + self!index-oor($pos), + nqp::if( + (my $reified := nqp::getattr(self,List,'$!reified')).DEFINITE, + nqp::stmts( + nqp::if( + (my $todo := nqp::getattr(self,List,'$!todo')).DEFINITE, + $todo.reify-at-least(nqp::add_i($pos,1)), + ), + nqp::if( + nqp::isle_i( # something to delete + $pos,my int $end = nqp::sub_i(nqp::elems($reified),1)), + nqp::stmts( + (my $value := nqp::ifnull( # save the value + nqp::atpos($reified,$pos), + self.default + )), + nqp::bindpos($reified,$pos,nqp::null), # remove this one + nqp::if( + nqp::iseq_i($pos,$end) && nqp::not_i(nqp::defined($todo)), + nqp::stmts( # shorten from end + (my int $i = $pos), + nqp::while( + (nqp::isge_i(($i = nqp::sub_i($i,1)),0) + && nqp::not_i(nqp::existspos($reified,$i))), + nqp::null + ), + nqp::setelems($reified,nqp::add_i($i,1)) + ), + ), + $value # value, if any + ), + self.default # outlander + ), + ), + self.default # no elements + ) + ) + } + multi method DELETE-POS(Array:D: Int:D $pos) is raw { + self.DELETE-POS(nqp::unbox_i($pos)) + } + + method !index-oor($pos) { + Failure.new(X::OutOfRange.new( + :what($*INDEX // 'Index'), :got($pos), :range<0..^Inf> + )) + } + + # MUST have a separate Slip variant to have it slip + multi method push(Array:D: Slip \value) { + self.is-lazy + ?? X::Cannot::Lazy.new(action => 'push to').throw + !! self!append-list(value) + } + multi method push(Array:D: \value) { + nqp::if( + self.is-lazy, + X::Cannot::Lazy.new(action => 'push to').throw, + nqp::stmts( + nqp::push( + nqp::if( + nqp::getattr(self,List,'$!reified').DEFINITE, + nqp::getattr(self,List,'$!reified'), + nqp::bindattr(self,List,'$!reified', + nqp::create(IterationBuffer)) + ), + nqp::assign(nqp::p6scalarfromdesc($!descriptor),value) + ), + self + ) + ) + } + multi method push(Array:D: **@values is raw) { + self.is-lazy + ?? X::Cannot::Lazy.new(action => 'push to').throw + !! self!append-list(@values) + } + + multi method append(Array:D: \value) { + nqp::if( + self.is-lazy, + X::Cannot::Lazy.new(action => 'append to').throw, + nqp::if( + (nqp::iscont(value) || nqp::not_i(nqp::istype(value, Iterable))), + nqp::stmts( + nqp::push( + nqp::if( + nqp::getattr(self,List,'$!reified').DEFINITE, + nqp::getattr(self,List,'$!reified'), + nqp::bindattr(self,List,'$!reified', + nqp::create(IterationBuffer)) + ), + nqp::assign(nqp::p6scalarfromdesc($!descriptor),value) + ), + self + ), + self!append-list(value.list) + ) + ) + } + multi method append(Array:D: **@values is raw) { + self.is-lazy + ?? X::Cannot::Lazy.new(action => 'append to').throw + !! self!append-list(@values) + } + method !append-list(@values) { + nqp::if( + nqp::eqaddr( + @values.iterator.push-until-lazy( + ArrayReificationTarget.new( + nqp::if( + nqp::getattr(self,List,'$!reified').DEFINITE, + nqp::getattr(self,List,'$!reified'), + nqp::bindattr(self,List,'$!reified', + nqp::create(IterationBuffer)) + ), + nqp::decont($!descriptor) + ) + ), + IterationEnd + ), + self, + X::Cannot::Lazy.new(:action,:what(self.^name)).throw + ) + } + + multi method unshift(Array:D: Slip \value) { + self!prepend-list(value) + } + multi method unshift(Array:D: \value) { + nqp::stmts( + nqp::unshift( + nqp::if( + nqp::getattr(self,List,'$!reified').DEFINITE, + nqp::getattr(self,List,'$!reified'), + nqp::bindattr(self,List,'$!reified', + nqp::create(IterationBuffer)) + ), + nqp::assign(nqp::p6scalarfromdesc($!descriptor),value) + ), + self + ) + } + multi method unshift(Array:D: **@values is raw) { + self!prepend-list(@values) + } + multi method prepend(Array:D: \value) { + nqp::if( + (nqp::iscont(value) || nqp::not_i(nqp::istype(value, Iterable))), + nqp::stmts( + nqp::unshift( + nqp::if( + nqp::getattr(self,List,'$!reified').DEFINITE, + nqp::getattr(self,List,'$!reified'), + nqp::bindattr(self,List,'$!reified', + nqp::create(IterationBuffer)) + ), + nqp::assign(nqp::p6scalarfromdesc($!descriptor),value) + ), + self + ), + self!prepend-list(value.list) + ) + } + multi method prepend(Array:D: **@values is raw) { + self!prepend-list(@values) + } + method !prepend-list(@values) { + nqp::stmts( + nqp::if( + nqp::getattr(self,List,'$!reified').DEFINITE, + nqp::splice(nqp::getattr(self,List,'$!reified'), # prepend existing + nqp::stmts( + @values.iterator.push-all( + ArrayReificationTarget.new( + (my $containers := nqp::create(IterationBuffer)), + nqp::decont($!descriptor) + ) + ), + $containers + ), + 0, + 0 + ), + @values.iterator.push-all( # no list yet, make this it + ArrayReificationTarget.new( + nqp::bindattr(self,List,'$!reified', + nqp::create(IterationBuffer)), + nqp::decont($!descriptor) + ) + ) + ), + self + ) + } + + method pop(Array:D:) is raw is nodal { + nqp::if( + self.is-lazy, + Failure.new(X::Cannot::Lazy.new(action => 'pop from')), + nqp::if( + (nqp::getattr(self,List,'$!reified').DEFINITE + && nqp::elems(nqp::getattr(self,List,'$!reified'))), + nqp::pop(nqp::getattr(self,List,'$!reified')), + Failure.new(X::Cannot::Empty.new(:action,:what(self.^name))) + ) + ) + } + + method shift(Array:D:) is raw is nodal { + nqp::if( + nqp::getattr(self,List,'$!reified').DEFINITE + && nqp::elems(nqp::getattr(self,List,'$!reified')), + nqp::ifnull( # handle holes + nqp::shift(nqp::getattr(self,List,'$!reified')), + Nil + ), + nqp::if( + (nqp::getattr(self,List,'$!todo').DEFINITE + && nqp::getattr(self,List,'$!todo').reify-at-least(1)), + nqp::shift(nqp::getattr(self,List,'$!reified')), + Failure.new(X::Cannot::Empty.new(:action,:what(self.^name))) + ) + ) + } + + my $empty := nqp::create(IterationBuffer); # splicing in without values + #------ splice() candidates + multi method splice(Array:D \SELF:) { + nqp::if( + nqp::getattr(SELF,List,'$!reified').DEFINITE, + nqp::stmts( + (my $result := nqp::create(SELF)), + nqp::bindattr($result,Array,'$!descriptor',$!descriptor), + nqp::stmts( # transplant the internals + nqp::bindattr($result,List,'$!reified', + nqp::getattr(SELF,List,'$!reified')), + nqp::if( + nqp::getattr(SELF,List,'$!todo').DEFINITE, + nqp::bindattr($result,List,'$!todo', + nqp::getattr(SELF,List,'$!todo')), + ) + ), + (SELF = nqp::create(SELF)), # XXX this preserves $!descriptor ?? + $result + ), + nqp::p6bindattrinvres( # nothing to return, so create new one + nqp::create(SELF),Array,'$!descriptor',$!descriptor) + ) + } + + #------ splice(offset) candidates + multi method splice(Array:D: Whatever $) { + nqp::p6bindattrinvres( # nothing to return, so create new one + nqp::create(self),Array,'$!descriptor',$!descriptor) + } + multi method splice(Array:D: Callable:D $offset) { + self.splice($offset(self.elems)) + } + multi method splice(Array:D: Int:D $offset) { + nqp::if( + $offset, + nqp::if( + nqp::islt_i(nqp::unbox_i($offset),0), + self!splice-offset-fail($offset), + nqp::if( + (my $todo := nqp::getattr(self,List,'$!todo')).DEFINITE, + nqp::if( + nqp::isge_i( + $todo.reify-at-least($offset),nqp::unbox_i($offset)), + self!splice-offset(nqp::unbox_i($offset)), + self!splice-offset-fail($offset) + ), + nqp::if( + (nqp::getattr(self,List,'$!reified').DEFINITE + && nqp::isge_i( + nqp::elems(nqp::getattr(self,List,'$!reified')), + nqp::unbox_i($offset))), + self!splice-offset(nqp::unbox_i($offset)), + self!splice-offset-fail($offset) + ) + ) + ), + self.splice # offset 0, take the quick route out + ) + } + method !splice-offset(int $offset) { + nqp::stmts( + (my int $elems = nqp::elems(nqp::getattr(self,List,'$!reified'))), + (my int $size = nqp::sub_i($elems,$offset)), + nqp::bindattr((my $result:= nqp::create(self)),List,'$!reified', + (my $buffer := nqp::setelems(nqp::create(IterationBuffer),$size))), + nqp::bindattr($result,Array,'$!descriptor',$!descriptor), + (my int $i = nqp::sub_i($offset,1)), + nqp::while( + nqp::islt_i(($i = nqp::add_i($i,1)),$elems), + nqp::bindpos($buffer,nqp::sub_i($i,$offset), + nqp::atpos(nqp::getattr(self,List,'$!reified'),$i)) + ), + nqp::splice( + nqp::getattr(self,List,'$!reified'),$empty,$offset,$size), + $result + ) + } + method !splice-offset-fail($got) { + X::OutOfRange.new( + :what('Offset argument to splice'), :$got, :range("0..{self.elems}") + ).throw + } + + #------ splice(offset,size) candidates + multi method splice(Array:D: Whatever $, Whatever $) { + nqp::p6bindattrinvres( # nothing to return, so create new one + nqp::create(self),Array,'$!descriptor',$!descriptor) + } + multi method splice(Array:D: Whatever $, Int:D $size) { + self.splice(self.elems,$size) + } + multi method splice(Array:D: Whatever $, Callable:D $size) { + my int $elems = self.elems; + self.splice($elems,$size(nqp::sub_i($elems,$elems))); + } + multi method splice(Array:D: Callable:D $offset, Callable:D $size) { + nqp::stmts( + (my int $elems = self.elems), + (my int $from = $offset($elems)), + self.splice($from,$size(nqp::sub_i($elems,$from))) + ) + } + multi method splice(Array:D: Callable:D $offset, Whatever $) { + self.splice($offset(self.elems)) + } + multi method splice(Array:D: Callable:D $offset, Int:D $size) { + self.splice($offset(self.elems),$size) + } + multi method splice(Array:D: Int:D $offset, Whatever $) { + self.splice($offset) + } + multi method splice(Array:D: Int:D $offset, Callable:D $size) { + self.splice($offset,$size(self.elems - $offset)) + } + multi method splice(Array:D: Int:D $offset, Int:D $size) { + nqp::if( + nqp::islt_i(nqp::unbox_i($offset),0), + self!splice-offset-fail($offset), + nqp::if( + nqp::islt_i(nqp::unbox_i($size),0), + self!splice-size-fail($size,$offset), + nqp::if( + (my $todo := nqp::getattr(self,List,'$!todo')).DEFINITE, + nqp::if( + nqp::isge_i( + $todo.reify-at-least( + nqp::add_i(nqp::unbox_i($offset),nqp::unbox_i($size)) + ),nqp::unbox_i($offset)), + self!splice-offset-size( + nqp::unbox_i($offset),nqp::unbox_i($size)), + self!splice-size-fail($size,$offset) + ), + nqp::if( + nqp::getattr(self,List,'$!reified').DEFINITE, + nqp::if( + nqp::isge_i( + nqp::elems(nqp::getattr(self,List,'$!reified')), + nqp::unbox_i($offset)), + self!splice-offset-size( + nqp::unbox_i($offset),nqp::unbox_i($size)), + self!splice-size-fail($size,$offset) + ), + nqp::if( + nqp::iseq_i(nqp::unbox_i($offset),0), + nqp::p6bindattrinvres( # nothing to return, create new + nqp::create(self),Array,'$!descriptor',$!descriptor), + self!splice-offset-fail($offset) + ) + ) + ) + ) + ) + } + method !splice-offset-size(int $offset,int $size) { + nqp::stmts( + (my $result := self!splice-save($offset,$size,my int $removed)), + nqp::splice( + nqp::getattr(self,List,'$!reified'),$empty,$offset,$removed), + $result + ) + } + method !splice-save(int $offset,int $size, \removed) { + nqp::stmts( + (removed = nqp::if( + nqp::isgt_i( + nqp::add_i($offset,$size), + nqp::elems(nqp::getattr(self,List,'$!reified')) + ), + nqp::sub_i(nqp::elems(nqp::getattr(self,List,'$!reified')),$offset), + $size + )), + nqp::if( + removed, + nqp::stmts( + nqp::bindattr((my $saved:= nqp::create(self)),List,'$!reified', + (my $buffer := + nqp::setelems(nqp::create(IterationBuffer),removed))), + nqp::bindattr($saved,Array,'$!descriptor',$!descriptor), + (my int $i = -1), + nqp::while( + nqp::islt_i(($i = nqp::add_i($i,1)),removed), + nqp::bindpos($buffer,$i,nqp::atpos( + nqp::getattr(self,List,'$!reified'),nqp::add_i($offset,$i))) + ), + $saved + ), + nqp::p6bindattrinvres( # effective size = 0, create new one + nqp::create(self),Array,'$!descriptor',$!descriptor) + ) + ) + } + method !splice-size-fail($got,$offset) { + nqp::if( + $offset > self.elems, + self!splice-offset-fail($offset), + X::OutOfRange.new( + :what('Size argument to splice'), + :$got, + :range("0..^{self.elems - $offset}") + ).throw + ) + } + #------ splice(offset,size,array) candidates + + # we have these 9 multies to avoid infiniloop when incorrect types are + # given to $offset/$size. Other attempts to resolve this showed 30%+ + # performance decreases + multi method splice(Array:D: Whatever $offset, Whatever $size, **@new) { self.splice($offset, $size, @new) } + multi method splice(Array:D: Whatever $offset, Callable:D $size, **@new) { self.splice($offset, $size, @new) } + multi method splice(Array:D: Whatever $offset, Int:D $size, **@new) { self.splice($offset, $size, @new) } + multi method splice(Array:D: Callable:D $offset, Whatever $size, **@new) { self.splice($offset, $size, @new) } + multi method splice(Array:D: Callable:D $offset, Callable:D $size, **@new) { self.splice($offset, $size, @new) } + multi method splice(Array:D: Callable:D $offset, Int:D $size, **@new) { self.splice($offset, $size, @new) } + multi method splice(Array:D: Int:D $offset, Whatever $size, **@new) { self.splice($offset, $size, @new) } + multi method splice(Array:D: Int:D $offset, Callable:D $size, **@new) { self.splice($offset, $size, @new) } + multi method splice(Array:D: Int:D $offset, Int:D $size, **@new) { self.splice($offset, $size, @new) } + + multi method splice(Array:D: Whatever $, Whatever $, @new) { + self.splice(self.elems,0,@new) + } + multi method splice(Array:D: Whatever $, Int:D $size, @new) { + self.splice(self.elems,$size,@new) + } + multi method splice(Array:D: Whatever $, Callable:D $size, @new) { + my int $elems = self.elems; + self.splice($elems,$size(nqp::sub_i($elems,$elems)),@new); + } + multi method splice(Array:D: Callable:D $offset, Callable:D $size, @new) { + nqp::stmts( + (my int $elems = self.elems), + (my int $from = $offset($elems)), + self.splice($from,$size(nqp::sub_i($elems,$from)),@new) + ) + } + multi method splice(Array:D: Callable:D $offset, Whatever $, @new) { + nqp::stmts( + (my int $elems = self.elems), + (my int $from = $offset($elems)), + self.splice($from,nqp::sub_i($elems,$from),@new) + ) + } + multi method splice(Array:D: Callable:D $offset, Int:D $size, @new) { + self.splice($offset(self.elems),$size,@new) + } + multi method splice(Array:D: Int:D $offset, Whatever $, @new) { + self.splice($offset,self.elems - $offset,@new) + } + multi method splice(Array:D: Int:D $offset, Callable:D $size, @new) { + self.splice($offset,$size(self.elems - $offset),@new) + } + multi method splice(Array:D: Int:D $offset, Int:D $size, @new) { + nqp::if( + nqp::islt_i(nqp::unbox_i($offset),0), + self!splice-offset-fail($offset), + nqp::if( + nqp::islt_i(nqp::unbox_i($size),0), + self!splice-size-fail($size,$offset), + nqp::if( + (my $todo := nqp::getattr(self,List,'$!todo')).DEFINITE, + nqp::if( + nqp::isge_i( + $todo.reify-at-least( + nqp::add_i(nqp::unbox_i($offset),nqp::unbox_i($size)) + ),nqp::unbox_i($offset)), + self!splice-offset-size-new( + nqp::unbox_i($offset),nqp::unbox_i($size),@new), + self!splice-size-fail($size,$offset) + ), + nqp::if( + nqp::isge_i( + nqp::elems(nqp::if( + nqp::getattr(self,List,'$!reified').DEFINITE, + nqp::getattr(self,List,'$!reified'), + nqp::bindattr(self,List,'$!reified', + nqp::create(IterationBuffer)) + )), + nqp::unbox_i($offset), + ), + self!splice-offset-size-new( + nqp::unbox_i($offset),nqp::unbox_i($size),@new), + self!splice-offset-fail($offset) + ) + ) + ) + ) + } + method !splice-offset-size-new(int $offset,int $size,@new) { + nqp::if( + nqp::eqaddr(@new.iterator.push-until-lazy( + (my $new := IterationBuffer.new)),IterationEnd), + nqp::if( # reified all values to splice in + (nqp::isnull($!descriptor) || nqp::eqaddr(self.of,Mu)), + nqp::stmts( # no typecheck needed + (my $result := self!splice-save($offset,$size,my int $removed)), + nqp::splice( + nqp::getattr(self,List,'$!reified'),$new,$offset,$removed), + $result + ), + nqp::stmts( # typecheck the values first + (my $expected := self.of), + (my int $elems = nqp::elems($new)), + (my int $i = -1), + nqp::while( + (nqp::islt_i(($i = nqp::add_i($i,1)),$elems) + && nqp::istype(nqp::atpos($new,$i),$expected)), + nqp::null + ), + nqp::if( + nqp::islt_i($i,$elems), # exited loop because of wrong type + X::TypeCheck::Splice.new( + :action, + :got(nqp::atpos($new,$i).WHAT), + :$expected + ).throw, + nqp::stmts( + ($result := self!splice-save($offset,$size,$removed)), + nqp::splice( + nqp::getattr(self,List,'$!reified'),$new,$offset,$removed), + $result + ) + ) + ) + ), + X::Cannot::Lazy.new(:action('splice in')).throw + ) + } + + multi method tail(Array:D: $n) { + nqp::if( + nqp::getattr(self,List,'$!todo').DEFINITE, + self.Any::tail($n), + Seq.new( + nqp::if( + (my $reified := nqp::getattr(self,List,'$!reified')).DEFINITE + && nqp::elems($reified), + nqp::stmts( + (my $iterator := Rakudo::Iterator.ReifiedArray( + self, + nqp::getattr(self,Array,'$!descriptor') + )), + nqp::if( + nqp::istype($n,Callable) + && nqp::isgt_i((my $skip := -($n(0).Int)),0), + $iterator.skip-at-least($skip), + nqp::unless( + nqp::istype($n,Whatever) || $n == Inf, + $iterator.skip-at-least(nqp::elems($reified) - $n) + ) + ), + $iterator + ), + Rakudo::Iterator.Empty + ) + ) + ) + } + + # introspection + method name() { + nqp::isnull($!descriptor) ?? Nil !! $!descriptor.name + } + method of() { + nqp::isnull($!descriptor) ?? Mu !! $!descriptor.of + } + method default() { + nqp::isnull($!descriptor) ?? Any !! $!descriptor.default + } + method dynamic() { + nqp::isnull($!descriptor) ?? False !! so $!descriptor.dynamic + } + multi method perl(Array:D \SELF:) { + SELF.perlseen('Array', { + '$' x nqp::iscont(SELF) # self is always deconted + ~ '[' + ~ self.map({nqp::decont($_).perl}).join(', ') + ~ ',' x (self.elems == 1 && nqp::istype(self.AT-POS(0),Iterable)) + ~ ']' + }) + } + multi method WHICH(Array:D:) { self.Mu::WHICH } + +#=============== class Array is closed in src/core/TypedArray.pm =============== + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/array_slice.pm rakudo-2018.03/src/core/array_slice.pm --- rakudo-2018.02.1/src/core/array_slice.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/array_slice.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,480 +0,0 @@ -# all sub postcircumfix [] candidates here please - -# Generates list of positions to index into the array at. Takes all those -# before something lazy is encountered and eagerly reifies them. If there -# are any lazy things in the slice, then we lazily consider those, but will -# truncate at the first one that is out of range. The optional -# :$eagerize will be called if Whatever/WhateverCode is encountered or if -# clipping of lazy indices is enacted. It should return the number of -# elements of the array if called with Whatever, or do something EXISTS-POSish -# if called with an Int. Before it does so, it may cause the calling code -# to switch to a memoized version of an iterator by modifying variables in -# the caller's scope. -proto sub POSITIONS(|) {*} -multi sub POSITIONS( - \SELF, - \pos, - Callable :$eagerize = -> \idx { - nqp::if( - nqp::istype(idx,Whatever), - nqp::if(nqp::isconcrete(SELF),SELF.elems,0), - SELF.EXISTS-POS(idx) - ) - } -) { - my class IndicesReificationTarget { - has $!target; - has $!star; - - method new(\target, \star) { - my \rt = nqp::create(self); - nqp::bindattr(rt, self, '$!target', target); - nqp::bindattr(rt, self, '$!star', star); - rt - } - - method push(Mu \value) { - nqp::if( - nqp::istype(value,Callable), - nqp::stmts( - nqp::if( - nqp::istype($!star,Callable), - nqp::bindattr(self,IndicesReificationTarget,'$!star',$!star(*)) - ), - # just using value(...) causes stage optimize to die - (my &whatever := value), - nqp::if( - &whatever.count == Inf, - nqp::push($!target, whatever(+$!star)), - nqp::push($!target, whatever(|(+$!star xx &whatever.count))) - ) - ), - nqp::push($!target,value) - ) - } - } - - # we can optimize `42..*` Ranges; as long as they're from core, unmodified - my \is-pos-lazy = pos.is-lazy; - my \pos-iter = nqp::eqaddr(pos.WHAT,Range) - && nqp::eqaddr(pos.max,Inf) - && nqp::isfalse(SELF.is-lazy) - ?? Range.new(pos.min, SELF.elems-1, - :excludes-min(pos.excludes-min), - :excludes-max(pos.excludes-max) - ).iterator - !! pos.iterator; - - my \pos-list = nqp::create(List); - my \eager-indices = nqp::create(IterationBuffer); - my \target = IndicesReificationTarget.new(eager-indices, $eagerize); - nqp::bindattr(pos-list, List, '$!reified', eager-indices); - - if is-pos-lazy { - # With lazy indices, we truncate at the first one that fails to exists. - my \rest-seq = Seq.new(pos-iter).flatmap: -> Int() $i { - nqp::unless( - $eagerize($i), - last, - $i - ) - }; - my \todo := nqp::create(List::Reifier); - nqp::bindattr(todo, List::Reifier, '$!reified', eager-indices); - nqp::bindattr(todo, List::Reifier, '$!current-iter', rest-seq.iterator); - nqp::bindattr(todo, List::Reifier, '$!reification-target', eager-indices); - nqp::bindattr(pos-list, List, '$!todo', todo); - } - else { - pos-iter.push-all: target; - } - pos-list -} - -proto sub postcircumfix:<[ ]>(|) is nodal {*} - -multi sub postcircumfix:<[ ]>( \SELF, Any:U $type, |c ) is raw { - die "Unable to call postcircumfix {try SELF.VAR.name}[ $type.gist() ] with a type object\n" - ~ "Indexing requires a defined object"; -} - -# @a[int 1] -multi sub postcircumfix:<[ ]>( \SELF, int $pos ) is raw { - SELF.AT-POS($pos); -} -multi sub postcircumfix:<[ ]>( \SELF, int $pos, Mu \assignee ) is raw { - SELF.ASSIGN-POS($pos, assignee); -} -multi sub postcircumfix:<[ ]>(\SELF, int $pos, Mu :$BIND! is raw) is raw { - SELF.BIND-POS($pos, $BIND); -} -multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$delete!, *%other ) is raw { - $delete && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? SELF.DELETE-POS($pos) - !! SLICE_ONE_LIST( SELF, $pos, 'delete', $delete, %other ); -} -multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$exists!, *%other ) is raw { - $exists && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? SELF.EXISTS-POS($pos) - !! SLICE_ONE_LIST( SELF, $pos, 'exists', $exists, %other ); -} -multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$kv!, *%other ) is raw { - $kv && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? (SELF.EXISTS-POS($pos) ?? ($pos, SELF.AT-POS($pos)) !! ()) - !! SLICE_ONE_LIST( SELF, $pos, 'kv', $kv, %other ); -} -multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$p!, *%other ) is raw { - $p && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? (SELF.EXISTS-POS($pos) ?? Pair.new($pos,SELF.AT-POS($pos)) !! ()) - !! SLICE_ONE_LIST( SELF, $pos, 'p', $p, %other ); -} -multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$k!, *%other ) is raw { - $k && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? (SELF.EXISTS-POS($pos) ?? $pos !! ()) - !! SLICE_ONE_LIST( SELF, $pos, 'k', $k, %other ); -} -multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$v!, *%other ) is raw { - $v && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? (SELF.EXISTS-POS($pos) ?? nqp::decont(SELF.AT-POS($pos)) !! ()) - !! SLICE_ONE_LIST( SELF, $pos, 'v', $v, %other ); -} - -# @a[Int 1] -multi sub postcircumfix:<[ ]>( \SELF, Int:D $pos ) is raw { - SELF.AT-POS($pos); -} -multi sub postcircumfix:<[ ]>( \SELF, Int:D $pos, Mu \assignee ) is raw { - SELF.ASSIGN-POS($pos, assignee); -} -multi sub postcircumfix:<[ ]>(\SELF, Int:D $pos, Mu :$BIND! is raw) is raw { - SELF.BIND-POS($pos, $BIND); -} -multi sub postcircumfix:<[ ]>( \SELF, Int:D $pos, :$delete!, *%other ) is raw { - $delete && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? SELF.DELETE-POS($pos) - !! SLICE_ONE_LIST( SELF, $pos, 'delete', $delete, %other ); -} -multi sub postcircumfix:<[ ]>( \SELF, Int:D $pos, :$exists!, *%other ) is raw { - $exists && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? SELF.EXISTS-POS($pos) - !! SLICE_ONE_LIST( SELF, $pos, 'exists', $exists, %other ); -} -multi sub postcircumfix:<[ ]>( \SELF, Int:D $pos, :$kv!, *%other ) is raw { - $kv && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? (SELF.EXISTS-POS($pos) ?? ($pos, SELF.AT-POS($pos)) !! ()) - !! SLICE_ONE_LIST( SELF, $pos, 'kv', $kv, %other ); -} -multi sub postcircumfix:<[ ]>( \SELF, Int:D $pos, :$p!, *%other ) is raw { - $p && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? (SELF.EXISTS-POS($pos) ?? Pair.new($pos,SELF.AT-POS($pos)) !! ()) - !! SLICE_ONE_LIST( SELF, $pos, 'p', $p, %other ); -} -multi sub postcircumfix:<[ ]>( \SELF, Int:D $pos, :$k!, *%other ) is raw { - $k && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? (SELF.EXISTS-POS($pos) ?? $pos !! ()) - !! SLICE_ONE_LIST( SELF, $pos, 'k', $k, %other ); -} -multi sub postcircumfix:<[ ]>( \SELF, Int:D $pos, :$v!, *%other ) is raw { - $v && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? (SELF.EXISTS-POS($pos) ?? nqp::decont(SELF.AT-POS($pos)) !! ()) - !! SLICE_ONE_LIST( SELF, $pos, 'v', $v, %other ); -} - -# @a[$x] -multi sub postcircumfix:<[ ]>( \SELF, Any:D \pos ) is raw { - SELF.AT-POS(pos.Int); -} -multi sub postcircumfix:<[ ]>( \SELF, Any:D \pos, Mu \assignee ) is raw { - SELF.ASSIGN-POS(pos.Int, assignee); -} -multi sub postcircumfix:<[ ]>(\SELF, Any:D \pos, Mu :$BIND! is raw) is raw { - SELF.BIND-POS(pos.Int, $BIND); -} -multi sub postcircumfix:<[ ]>( \SELF, Any:D \pos, :$delete!, *%other ) is raw { - $delete && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? SELF.DELETE-POS(pos.Int) - !! SLICE_ONE_LIST( SELF, pos.Int, 'delete', $delete, %other ); -} -multi sub postcircumfix:<[ ]>( \SELF, Any:D \pos, :$exists!, *%other ) is raw { - $exists && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? SELF.EXISTS-POS(pos.Int) - !! SLICE_ONE_LIST( SELF, pos.Int, 'exists', $exists, %other ); -} -multi sub postcircumfix:<[ ]>( \SELF, Any:D \pos, :$kv!, *%other ) is raw { - $kv && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? (SELF.EXISTS-POS(pos.Int) ?? (pos, SELF.AT-POS(pos.Int)) !! ()) - !! SLICE_ONE_LIST( SELF, pos.Int, 'kv', $kv, %other ); -} -multi sub postcircumfix:<[ ]>( \SELF, Any:D \pos, :$p!, *%other ) is raw { - $p && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? (SELF.EXISTS-POS(pos.Int) ?? Pair.new(pos, SELF.AT-POS(pos.Int)) !! ()) - !! SLICE_ONE_LIST( SELF, pos.Int, 'p', $p, %other ); -} -multi sub postcircumfix:<[ ]>( \SELF, Any:D \pos, :$k!, *%other ) is raw { - $k && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? (SELF.EXISTS-POS(pos.Int) ?? pos !! ()) - !! SLICE_ONE_LIST( SELF, pos.Int, 'k', $k, %other ); -} -multi sub postcircumfix:<[ ]>( \SELF, Any:D \pos, :$v!, *%other ) is raw { - $v && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? (SELF.EXISTS-POS(pos.Int) ?? nqp::decont(SELF.AT-POS(pos.Int)) !! ()) - !! SLICE_ONE_LIST( SELF, pos.Int, 'v', $v, %other ); -} - -# @a[@i] -multi sub postcircumfix:<[ ]>( \SELF, Iterable:D \pos ) is raw { - nqp::iscont(pos) - ?? SELF.AT-POS(pos.Int) - !! POSITIONS(SELF, pos).map({ SELF[$_] }).eager.list; -} -multi sub postcircumfix:<[ ]>(\SELF, Iterable:D \pos, Mu \val ) is raw { - # MMD is not behaving itself so we do this by hand. - if nqp::iscont(pos) { - return SELF[pos.Int] = val; - } - - # Prep an iterator that will assign Nils past end of rval - my \rvlist := - do if nqp::iscont(val) - or not nqp::istype(val, Iterator) - and not nqp::istype(val, Iterable) { - (nqp::decont(val),).Slip - } - elsif nqp::istype(val, Iterator) { - Slip.from-loop({ nqp::decont(val.pull-one) }) - } - elsif nqp::istype(val, Iterable) { - val.map({ nqp::decont($_) }).Slip - }, (Nil xx Inf).Slip; - - if nqp::istype(SELF, Positional) { - # For Positionals, preserve established/expected evaluation order. - my $list := List.new; - my $target := nqp::getattr($list,List,'$!reified'); - - # We try to reify indices eagerly first, in case doing so - # manipulates SELF. If pos is lazy or contains Whatevers/closures, - # the SELF may start to reify as well. - my \indices := POSITIONS(SELF, pos); - indices.iterator.sink-all; - - # Extract the values/containers which will be assigned to, in case - # reifying the rhs does crazy things like splicing SELF. - my int $p = -1; - nqp::bindpos($target,++$p,SELF[$_]) for indices; - - rvlist.EXISTS-POS($p); - my \rviter := rvlist.iterator; - $p = -1; - my $elems = nqp::elems($target); - nqp::atpos($target,$p) = rviter.pull-one - while nqp::islt_i(++$p,$elems); - $list - } - else { # The assumption for now is this must be Iterable - # Lazy list assignment. This is somewhat experimental and - # semantics may change. - my $target := SELF.iterator; - my sub eagerize ($idx) { - once $target := $target.cache.iterator; - $idx ~~ Whatever ?? $target.elems !! $target.EXISTS-POS($idx); - } - my @poslist := POSITIONS(SELF, pos, :eagerize(&eagerize)).eager; - my %keep; - # TODO: we could also use a quanthash and count occurences of an - # index to let things go to GC sooner. - %keep{@poslist} = (); - my $max = -1; - my \rviter := rvlist.iterator; - @poslist.map: -> $p { - my $lv; - for $max ^.. $p -> $i { - $max = $i; - my $lv := $target.pull-one; - %keep{$i} := $lv - if %keep{$i}:exists and !($lv =:= IterationEnd); - } - $lv := %keep{$p}; - $lv = rviter.pull-one; - }; - } -} -multi sub postcircumfix:<[ ]>(\SELF, Iterable:D \pos, :$BIND!) is raw { - X::Bind::Slice.new(type => SELF.WHAT).throw; -} -multi sub postcircumfix:<[ ]>(\SELF, Iterable:D \pos,:$delete!,*%other) is raw { - nqp::iscont(pos) - ?? SLICE_ONE_LIST( SELF, pos.Int, 'delete', $delete, %other ) - !! SLICE_MORE_LIST(SELF,POSITIONS(SELF,pos),'delete',$delete,%other) -} -multi sub postcircumfix:<[ ]>(\SELF, Iterable:D \pos,:$exists!,*%other) is raw { - nqp::iscont(pos) - ?? SLICE_ONE_LIST( SELF, pos.Int, 'exists', $exists, %other ) - !! SLICE_MORE_LIST(SELF,POSITIONS(SELF,pos),'exists',$exists,%other) -} -multi sub postcircumfix:<[ ]>(\SELF, Iterable:D \pos, :$kv!, *%other) is raw { - nqp::iscont(pos) - ?? SLICE_ONE_LIST( SELF, pos.Int, 'kv', $kv, %other ) - !! SLICE_MORE_LIST(SELF,POSITIONS(SELF,pos),'kv',$kv,%other) -} -multi sub postcircumfix:<[ ]>(\SELF, Iterable:D \pos, :$p!, *%other) is raw { - nqp::iscont(pos) - ?? SLICE_ONE_LIST( SELF, pos.Int, 'p', $p, %other ) - !! SLICE_MORE_LIST(SELF,POSITIONS(SELF,pos),'p',$p,%other) -} -multi sub postcircumfix:<[ ]>(\SELF, Iterable:D \pos, :$k!, *%other) is raw { - nqp::iscont(pos) - ?? SLICE_ONE_LIST( SELF, pos.Int, 'k', $k, %other ) - !! SLICE_MORE_LIST(SELF,POSITIONS(SELF,pos),'k',$k,%other) -} -multi sub postcircumfix:<[ ]>(\SELF, Iterable:D \pos, :$v!, *%other) is raw { - nqp::iscont(pos) - ?? SLICE_ONE_LIST( SELF, pos.Int, 'v', $v, %other ) - !! SLICE_MORE_LIST(SELF,POSITIONS(SELF,pos),'v',$v,%other) -} - -# @a[->{}] -multi sub postcircumfix:<[ ]>(\SELF, Callable:D $block ) is raw { - nqp::stmts( - (my $*INDEX = 'Effective index'), - SELF[$block.pos(SELF)] - ) -} -multi sub postcircumfix:<[ ]>(\SELF, Callable:D $block, Mu \assignee ) is raw { - nqp::stmts( - (my $*INDEX = 'Effective index'), - SELF[$block.pos(SELF)] = assignee - ) -} -multi sub postcircumfix:<[ ]>(\SELF, Callable:D $block, :$BIND!) is raw { - X::Bind::Slice.new(type => SELF.WHAT).throw; -} -multi sub postcircumfix:<[ ]>(\SELF,Callable:D $block,:$delete!,*%other) is raw { - nqp::stmts( - (my $*INDEX = 'Effective index'), - nqp::if( - nqp::istype((my $pos := $block.pos(SELF)),Int), - SLICE_ONE_LIST( SELF, $pos, 'delete', $delete, %other ), - SLICE_MORE_LIST( SELF, @$pos, 'delete', $delete, %other ) - ) - ) -} -multi sub postcircumfix:<[ ]>(\SELF,Callable:D $block,:$exists!,*%other) is raw { - nqp::stmts( - (my $*INDEX = 'Effective index'), - nqp::if( - nqp::istype((my $pos := $block.pos(SELF)),Int), - SLICE_ONE_LIST( SELF, $pos, 'exists', $exists, %other ), - SLICE_MORE_LIST( SELF, @$pos, 'exists', $exists, %other ) - ) - ) -} -multi sub postcircumfix:<[ ]>(\SELF,Callable:D $block,:$kv!,*%other) is raw { - nqp::stmts( - (my $*INDEX = 'Effective index'), - nqp::if( - nqp::istype((my $pos := $block.pos(SELF)),Int), - SLICE_ONE_LIST( SELF, $pos, 'kv', $kv, %other ), - SLICE_MORE_LIST( SELF, @$pos, 'kv', $kv, %other ) - ) - ) -} -multi sub postcircumfix:<[ ]>(\SELF,Callable:D $block,:$p!,*%other) is raw { - nqp::stmts( - (my $*INDEX = 'Effective index'), - nqp::if( - nqp::istype((my $pos := $block.pos(SELF)),Int), - SLICE_ONE_LIST( SELF, $pos, 'p', $p, %other ), - SLICE_MORE_LIST( SELF, @$pos, 'p', $p, %other ) - ) - ) -} -multi sub postcircumfix:<[ ]>(\SELF,Callable:D $block,:$k!,*%other) is raw { - nqp::stmts( - (my $*INDEX = 'Effective index'), - nqp::if( - nqp::istype((my $pos := $block.pos(SELF)),Int), - SLICE_ONE_LIST( SELF, $pos, 'k', $k, %other ), - SLICE_MORE_LIST( SELF, @$pos, 'k', $k, %other ) - ) - ) -} -multi sub postcircumfix:<[ ]>(\SELF,Callable:D $block,:$v!,*%other) is raw { - nqp::stmts( - (my $*INDEX = 'Effective index'), - nqp::if( - nqp::istype((my $pos := $block.pos(SELF)),Int), - SLICE_ONE_LIST( SELF, $pos, 'v', $v, %other ), - SLICE_MORE_LIST( SELF, @$pos, 'v', $v, %other ) - ) - ) -} - -# @a[*] -multi sub postcircumfix:<[ ]>( \SELF, Whatever:D ) is raw { - SELF[^SELF.elems]; -} -multi sub postcircumfix:<[ ]>( \SELF, Whatever:D, Mu \assignee ) is raw { - SELF[^SELF.elems] = assignee; -} -multi sub postcircumfix:<[ ]>(\SELF, Whatever:D, :$BIND!) is raw { - X::Bind::Slice.new(type => SELF.WHAT).throw; -} -multi sub postcircumfix:<[ ]>(\SELF, Whatever:D, :$delete!, *%other) is raw { - SLICE_MORE_LIST( SELF, ^SELF.elems, 'delete', $delete, %other ); -} -multi sub postcircumfix:<[ ]>(\SELF, Whatever:D, :$exists!, *%other) is raw { - SLICE_MORE_LIST( SELF, ^SELF.elems, 'exists', $exists, %other ); -} -multi sub postcircumfix:<[ ]>(\SELF, Whatever:D, :$kv!, *%other) is raw { - SLICE_MORE_LIST( SELF, ^SELF.elems, 'kv', $kv, %other ); -} -multi sub postcircumfix:<[ ]>(\SELF, Whatever:D, :$p!, *%other) is raw { - SLICE_MORE_LIST( SELF, ^SELF.elems, 'p', $p, %other ); -} -multi sub postcircumfix:<[ ]>(\SELF, Whatever:D, :$k!, *%other) is raw { - SLICE_MORE_LIST( SELF, ^SELF.elems, 'k', $k, %other ); -} -multi sub postcircumfix:<[ ]>(\SELF, Whatever:D, :$v!, *%other) is raw { - nqp::elems(nqp::getattr(%other,Map,'$!storage')) - ?? SLICE_MORE_LIST( SELF, ^SELF.elems, 'v', $v, %other ) - !! SELF[^SELF.elems]; -} - -# @a[**] -multi sub postcircumfix:<[ ]>(\SELF, HyperWhatever:D $, *%adv) is raw { - X::NYI.new(feature => 'HyperWhatever in array index').throw; -} -multi sub postcircumfix:<[ ]>(\SELF, HyperWhatever:D $, Mu \assignee) is raw { - X::NYI.new(feature => 'HyperWhatever in array index').throw; -} - -# @a[] -multi sub postcircumfix:<[ ]>(\SELF, :$BIND!) is raw { - X::Bind::ZenSlice.new(type => SELF.WHAT).throw; -} -multi sub postcircumfix:<[ ]>(\SELF, :$delete!, *%other) is raw { - SLICE_MORE_LIST( SELF, ^SELF.elems, 'delete', $delete, %other ); -} -multi sub postcircumfix:<[ ]>(\SELF, :$exists!, *%other) is raw { - SLICE_MORE_LIST( SELF, ^SELF.elems, 'exists', $exists, %other ); -} -multi sub postcircumfix:<[ ]>(\SELF, :$kv!, *%other) is raw { - SLICE_MORE_LIST( SELF, ^SELF.elems, 'kv', $kv, %other ); -} -multi sub postcircumfix:<[ ]>(\SELF, :$p!, *%other) is raw { - SLICE_MORE_LIST( SELF, ^SELF.elems, 'p', $p, %other ); -} -multi sub postcircumfix:<[ ]>(\SELF, :$k!, *%other) is raw { - SLICE_MORE_LIST( SELF, ^SELF.elems, 'k', $k, %other ); -} -multi sub postcircumfix:<[ ]>(\SELF, :$v!, *%other) is raw { - nqp::elems(nqp::getattr(%other,Map,'$!storage')) - ?? SLICE_MORE_LIST( SELF, ^SELF.elems, 'v', $v, %other ) - !! SELF[^SELF.elems]; -} -multi sub postcircumfix:<[ ]>(\SELF, *%other) is raw { - SELF.ZEN-POS(|%other); -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/array_slice.pm6 rakudo-2018.03/src/core/array_slice.pm6 --- rakudo-2018.02.1/src/core/array_slice.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/array_slice.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,480 @@ +# all sub postcircumfix [] candidates here please + +# Generates list of positions to index into the array at. Takes all those +# before something lazy is encountered and eagerly reifies them. If there +# are any lazy things in the slice, then we lazily consider those, but will +# truncate at the first one that is out of range. The optional +# :$eagerize will be called if Whatever/WhateverCode is encountered or if +# clipping of lazy indices is enacted. It should return the number of +# elements of the array if called with Whatever, or do something EXISTS-POSish +# if called with an Int. Before it does so, it may cause the calling code +# to switch to a memoized version of an iterator by modifying variables in +# the caller's scope. +proto sub POSITIONS(|) {*} +multi sub POSITIONS( + \SELF, + \pos, + Callable :$eagerize = -> \idx { + nqp::if( + nqp::istype(idx,Whatever), + nqp::if(nqp::isconcrete(SELF),SELF.elems,0), + SELF.EXISTS-POS(idx) + ) + } +) { + my class IndicesReificationTarget { + has $!target; + has $!star; + + method new(\target, \star) { + my \rt = nqp::create(self); + nqp::bindattr(rt, self, '$!target', target); + nqp::bindattr(rt, self, '$!star', star); + rt + } + + method push(Mu \value) { + nqp::if( + nqp::istype(value,Callable), + nqp::stmts( + nqp::if( + nqp::istype($!star,Callable), + nqp::bindattr(self,IndicesReificationTarget,'$!star',$!star(*)) + ), + # just using value(...) causes stage optimize to die + (my &whatever := value), + nqp::if( + &whatever.count == Inf, + nqp::push($!target, whatever(+$!star)), + nqp::push($!target, whatever(|(+$!star xx &whatever.count))) + ) + ), + nqp::push($!target,value) + ) + } + } + + # we can optimize `42..*` Ranges; as long as they're from core, unmodified + my \is-pos-lazy = pos.is-lazy; + my \pos-iter = nqp::eqaddr(pos.WHAT,Range) + && nqp::eqaddr(pos.max,Inf) + && nqp::isfalse(SELF.is-lazy) + ?? Range.new(pos.min, SELF.elems-1, + :excludes-min(pos.excludes-min), + :excludes-max(pos.excludes-max) + ).iterator + !! pos.iterator; + + my \pos-list = nqp::create(List); + my \eager-indices = nqp::create(IterationBuffer); + my \target = IndicesReificationTarget.new(eager-indices, $eagerize); + nqp::bindattr(pos-list, List, '$!reified', eager-indices); + + if is-pos-lazy { + # With lazy indices, we truncate at the first one that fails to exists. + my \rest-seq = Seq.new(pos-iter).flatmap: -> Int() $i { + nqp::unless( + $eagerize($i), + last, + $i + ) + }; + my \todo := nqp::create(List::Reifier); + nqp::bindattr(todo, List::Reifier, '$!reified', eager-indices); + nqp::bindattr(todo, List::Reifier, '$!current-iter', rest-seq.iterator); + nqp::bindattr(todo, List::Reifier, '$!reification-target', eager-indices); + nqp::bindattr(pos-list, List, '$!todo', todo); + } + else { + pos-iter.push-all: target; + } + pos-list +} + +proto sub postcircumfix:<[ ]>(|) is nodal {*} + +multi sub postcircumfix:<[ ]>( \SELF, Any:U $type, |c ) is raw { + die "Unable to call postcircumfix {try SELF.VAR.name}[ $type.gist() ] with a type object\n" + ~ "Indexing requires a defined object"; +} + +# @a[int 1] +multi sub postcircumfix:<[ ]>( \SELF, int $pos ) is raw { + SELF.AT-POS($pos); +} +multi sub postcircumfix:<[ ]>( \SELF, int $pos, Mu \assignee ) is raw { + SELF.ASSIGN-POS($pos, assignee); +} +multi sub postcircumfix:<[ ]>(\SELF, int $pos, Mu :$BIND! is raw) is raw { + SELF.BIND-POS($pos, $BIND); +} +multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$delete!, *%other ) is raw { + $delete && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? SELF.DELETE-POS($pos) + !! SLICE_ONE_LIST( SELF, $pos, 'delete', $delete, %other ); +} +multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$exists!, *%other ) is raw { + $exists && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? SELF.EXISTS-POS($pos) + !! SLICE_ONE_LIST( SELF, $pos, 'exists', $exists, %other ); +} +multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$kv!, *%other ) is raw { + $kv && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? (SELF.EXISTS-POS($pos) ?? ($pos, SELF.AT-POS($pos)) !! ()) + !! SLICE_ONE_LIST( SELF, $pos, 'kv', $kv, %other ); +} +multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$p!, *%other ) is raw { + $p && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? (SELF.EXISTS-POS($pos) ?? Pair.new($pos,SELF.AT-POS($pos)) !! ()) + !! SLICE_ONE_LIST( SELF, $pos, 'p', $p, %other ); +} +multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$k!, *%other ) is raw { + $k && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? (SELF.EXISTS-POS($pos) ?? $pos !! ()) + !! SLICE_ONE_LIST( SELF, $pos, 'k', $k, %other ); +} +multi sub postcircumfix:<[ ]>( \SELF, int $pos, :$v!, *%other ) is raw { + $v && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? (SELF.EXISTS-POS($pos) ?? nqp::decont(SELF.AT-POS($pos)) !! ()) + !! SLICE_ONE_LIST( SELF, $pos, 'v', $v, %other ); +} + +# @a[Int 1] +multi sub postcircumfix:<[ ]>( \SELF, Int:D $pos ) is raw { + SELF.AT-POS($pos); +} +multi sub postcircumfix:<[ ]>( \SELF, Int:D $pos, Mu \assignee ) is raw { + SELF.ASSIGN-POS($pos, assignee); +} +multi sub postcircumfix:<[ ]>(\SELF, Int:D $pos, Mu :$BIND! is raw) is raw { + SELF.BIND-POS($pos, $BIND); +} +multi sub postcircumfix:<[ ]>( \SELF, Int:D $pos, :$delete!, *%other ) is raw { + $delete && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? SELF.DELETE-POS($pos) + !! SLICE_ONE_LIST( SELF, $pos, 'delete', $delete, %other ); +} +multi sub postcircumfix:<[ ]>( \SELF, Int:D $pos, :$exists!, *%other ) is raw { + $exists && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? SELF.EXISTS-POS($pos) + !! SLICE_ONE_LIST( SELF, $pos, 'exists', $exists, %other ); +} +multi sub postcircumfix:<[ ]>( \SELF, Int:D $pos, :$kv!, *%other ) is raw { + $kv && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? (SELF.EXISTS-POS($pos) ?? ($pos, SELF.AT-POS($pos)) !! ()) + !! SLICE_ONE_LIST( SELF, $pos, 'kv', $kv, %other ); +} +multi sub postcircumfix:<[ ]>( \SELF, Int:D $pos, :$p!, *%other ) is raw { + $p && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? (SELF.EXISTS-POS($pos) ?? Pair.new($pos,SELF.AT-POS($pos)) !! ()) + !! SLICE_ONE_LIST( SELF, $pos, 'p', $p, %other ); +} +multi sub postcircumfix:<[ ]>( \SELF, Int:D $pos, :$k!, *%other ) is raw { + $k && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? (SELF.EXISTS-POS($pos) ?? $pos !! ()) + !! SLICE_ONE_LIST( SELF, $pos, 'k', $k, %other ); +} +multi sub postcircumfix:<[ ]>( \SELF, Int:D $pos, :$v!, *%other ) is raw { + $v && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? (SELF.EXISTS-POS($pos) ?? nqp::decont(SELF.AT-POS($pos)) !! ()) + !! SLICE_ONE_LIST( SELF, $pos, 'v', $v, %other ); +} + +# @a[$x] +multi sub postcircumfix:<[ ]>( \SELF, Any:D \pos ) is raw { + SELF.AT-POS(pos.Int); +} +multi sub postcircumfix:<[ ]>( \SELF, Any:D \pos, Mu \assignee ) is raw { + SELF.ASSIGN-POS(pos.Int, assignee); +} +multi sub postcircumfix:<[ ]>(\SELF, Any:D \pos, Mu :$BIND! is raw) is raw { + SELF.BIND-POS(pos.Int, $BIND); +} +multi sub postcircumfix:<[ ]>( \SELF, Any:D \pos, :$delete!, *%other ) is raw { + $delete && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? SELF.DELETE-POS(pos.Int) + !! SLICE_ONE_LIST( SELF, pos.Int, 'delete', $delete, %other ); +} +multi sub postcircumfix:<[ ]>( \SELF, Any:D \pos, :$exists!, *%other ) is raw { + $exists && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? SELF.EXISTS-POS(pos.Int) + !! SLICE_ONE_LIST( SELF, pos.Int, 'exists', $exists, %other ); +} +multi sub postcircumfix:<[ ]>( \SELF, Any:D \pos, :$kv!, *%other ) is raw { + $kv && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? (SELF.EXISTS-POS(pos.Int) ?? (pos, SELF.AT-POS(pos.Int)) !! ()) + !! SLICE_ONE_LIST( SELF, pos.Int, 'kv', $kv, %other ); +} +multi sub postcircumfix:<[ ]>( \SELF, Any:D \pos, :$p!, *%other ) is raw { + $p && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? (SELF.EXISTS-POS(pos.Int) ?? Pair.new(pos, SELF.AT-POS(pos.Int)) !! ()) + !! SLICE_ONE_LIST( SELF, pos.Int, 'p', $p, %other ); +} +multi sub postcircumfix:<[ ]>( \SELF, Any:D \pos, :$k!, *%other ) is raw { + $k && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? (SELF.EXISTS-POS(pos.Int) ?? pos !! ()) + !! SLICE_ONE_LIST( SELF, pos.Int, 'k', $k, %other ); +} +multi sub postcircumfix:<[ ]>( \SELF, Any:D \pos, :$v!, *%other ) is raw { + $v && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? (SELF.EXISTS-POS(pos.Int) ?? nqp::decont(SELF.AT-POS(pos.Int)) !! ()) + !! SLICE_ONE_LIST( SELF, pos.Int, 'v', $v, %other ); +} + +# @a[@i] +multi sub postcircumfix:<[ ]>( \SELF, Iterable:D \pos ) is raw { + nqp::iscont(pos) + ?? SELF.AT-POS(pos.Int) + !! POSITIONS(SELF, pos).map({ SELF[$_] }).eager.list; +} +multi sub postcircumfix:<[ ]>(\SELF, Iterable:D \pos, Mu \val ) is raw { + # MMD is not behaving itself so we do this by hand. + if nqp::iscont(pos) { + return SELF[pos.Int] = val; + } + + # Prep an iterator that will assign Nils past end of rval + my \rvlist := + do if nqp::iscont(val) + or not nqp::istype(val, Iterator) + and not nqp::istype(val, Iterable) { + (nqp::decont(val),).Slip + } + elsif nqp::istype(val, Iterator) { + Slip.from-loop({ nqp::decont(val.pull-one) }) + } + elsif nqp::istype(val, Iterable) { + val.map({ nqp::decont($_) }).Slip + }, (Nil xx Inf).Slip; + + if nqp::istype(SELF, Positional) { + # For Positionals, preserve established/expected evaluation order. + my $list := List.new; + my $target := nqp::getattr($list,List,'$!reified'); + + # We try to reify indices eagerly first, in case doing so + # manipulates SELF. If pos is lazy or contains Whatevers/closures, + # the SELF may start to reify as well. + my \indices := POSITIONS(SELF, pos); + indices.iterator.sink-all; + + # Extract the values/containers which will be assigned to, in case + # reifying the rhs does crazy things like splicing SELF. + my int $p = -1; + nqp::bindpos($target,++$p,SELF[$_]) for indices; + + rvlist.EXISTS-POS($p); + my \rviter := rvlist.iterator; + $p = -1; + my $elems = nqp::elems($target); + nqp::atpos($target,$p) = rviter.pull-one + while nqp::islt_i(++$p,$elems); + $list + } + else { # The assumption for now is this must be Iterable + # Lazy list assignment. This is somewhat experimental and + # semantics may change. + my $target := SELF.iterator; + my sub eagerize ($idx) { + once $target := $target.cache.iterator; + $idx ~~ Whatever ?? $target.elems !! $target.EXISTS-POS($idx); + } + my @poslist := POSITIONS(SELF, pos, :eagerize(&eagerize)).eager; + my %keep; + # TODO: we could also use a quanthash and count occurences of an + # index to let things go to GC sooner. + %keep{@poslist} = (); + my $max = -1; + my \rviter := rvlist.iterator; + @poslist.map: -> $p { + my $lv; + for $max ^.. $p -> $i { + $max = $i; + my $lv := $target.pull-one; + %keep{$i} := $lv + if %keep{$i}:exists and !($lv =:= IterationEnd); + } + $lv := %keep{$p}; + $lv = rviter.pull-one; + }; + } +} +multi sub postcircumfix:<[ ]>(\SELF, Iterable:D \pos, :$BIND!) is raw { + X::Bind::Slice.new(type => SELF.WHAT).throw; +} +multi sub postcircumfix:<[ ]>(\SELF, Iterable:D \pos,:$delete!,*%other) is raw { + nqp::iscont(pos) + ?? SLICE_ONE_LIST( SELF, pos.Int, 'delete', $delete, %other ) + !! SLICE_MORE_LIST(SELF,POSITIONS(SELF,pos),'delete',$delete,%other) +} +multi sub postcircumfix:<[ ]>(\SELF, Iterable:D \pos,:$exists!,*%other) is raw { + nqp::iscont(pos) + ?? SLICE_ONE_LIST( SELF, pos.Int, 'exists', $exists, %other ) + !! SLICE_MORE_LIST(SELF,POSITIONS(SELF,pos),'exists',$exists,%other) +} +multi sub postcircumfix:<[ ]>(\SELF, Iterable:D \pos, :$kv!, *%other) is raw { + nqp::iscont(pos) + ?? SLICE_ONE_LIST( SELF, pos.Int, 'kv', $kv, %other ) + !! SLICE_MORE_LIST(SELF,POSITIONS(SELF,pos),'kv',$kv,%other) +} +multi sub postcircumfix:<[ ]>(\SELF, Iterable:D \pos, :$p!, *%other) is raw { + nqp::iscont(pos) + ?? SLICE_ONE_LIST( SELF, pos.Int, 'p', $p, %other ) + !! SLICE_MORE_LIST(SELF,POSITIONS(SELF,pos),'p',$p,%other) +} +multi sub postcircumfix:<[ ]>(\SELF, Iterable:D \pos, :$k!, *%other) is raw { + nqp::iscont(pos) + ?? SLICE_ONE_LIST( SELF, pos.Int, 'k', $k, %other ) + !! SLICE_MORE_LIST(SELF,POSITIONS(SELF,pos),'k',$k,%other) +} +multi sub postcircumfix:<[ ]>(\SELF, Iterable:D \pos, :$v!, *%other) is raw { + nqp::iscont(pos) + ?? SLICE_ONE_LIST( SELF, pos.Int, 'v', $v, %other ) + !! SLICE_MORE_LIST(SELF,POSITIONS(SELF,pos),'v',$v,%other) +} + +# @a[->{}] +multi sub postcircumfix:<[ ]>(\SELF, Callable:D $block ) is raw { + nqp::stmts( + (my $*INDEX = 'Effective index'), + SELF[$block.pos(SELF)] + ) +} +multi sub postcircumfix:<[ ]>(\SELF, Callable:D $block, Mu \assignee ) is raw { + nqp::stmts( + (my $*INDEX = 'Effective index'), + SELF[$block.pos(SELF)] = assignee + ) +} +multi sub postcircumfix:<[ ]>(\SELF, Callable:D $block, :$BIND!) is raw { + X::Bind::Slice.new(type => SELF.WHAT).throw; +} +multi sub postcircumfix:<[ ]>(\SELF,Callable:D $block,:$delete!,*%other) is raw { + nqp::stmts( + (my $*INDEX = 'Effective index'), + nqp::if( + nqp::istype((my $pos := $block.pos(SELF)),Int), + SLICE_ONE_LIST( SELF, $pos, 'delete', $delete, %other ), + SLICE_MORE_LIST( SELF, @$pos, 'delete', $delete, %other ) + ) + ) +} +multi sub postcircumfix:<[ ]>(\SELF,Callable:D $block,:$exists!,*%other) is raw { + nqp::stmts( + (my $*INDEX = 'Effective index'), + nqp::if( + nqp::istype((my $pos := $block.pos(SELF)),Int), + SLICE_ONE_LIST( SELF, $pos, 'exists', $exists, %other ), + SLICE_MORE_LIST( SELF, @$pos, 'exists', $exists, %other ) + ) + ) +} +multi sub postcircumfix:<[ ]>(\SELF,Callable:D $block,:$kv!,*%other) is raw { + nqp::stmts( + (my $*INDEX = 'Effective index'), + nqp::if( + nqp::istype((my $pos := $block.pos(SELF)),Int), + SLICE_ONE_LIST( SELF, $pos, 'kv', $kv, %other ), + SLICE_MORE_LIST( SELF, @$pos, 'kv', $kv, %other ) + ) + ) +} +multi sub postcircumfix:<[ ]>(\SELF,Callable:D $block,:$p!,*%other) is raw { + nqp::stmts( + (my $*INDEX = 'Effective index'), + nqp::if( + nqp::istype((my $pos := $block.pos(SELF)),Int), + SLICE_ONE_LIST( SELF, $pos, 'p', $p, %other ), + SLICE_MORE_LIST( SELF, @$pos, 'p', $p, %other ) + ) + ) +} +multi sub postcircumfix:<[ ]>(\SELF,Callable:D $block,:$k!,*%other) is raw { + nqp::stmts( + (my $*INDEX = 'Effective index'), + nqp::if( + nqp::istype((my $pos := $block.pos(SELF)),Int), + SLICE_ONE_LIST( SELF, $pos, 'k', $k, %other ), + SLICE_MORE_LIST( SELF, @$pos, 'k', $k, %other ) + ) + ) +} +multi sub postcircumfix:<[ ]>(\SELF,Callable:D $block,:$v!,*%other) is raw { + nqp::stmts( + (my $*INDEX = 'Effective index'), + nqp::if( + nqp::istype((my $pos := $block.pos(SELF)),Int), + SLICE_ONE_LIST( SELF, $pos, 'v', $v, %other ), + SLICE_MORE_LIST( SELF, @$pos, 'v', $v, %other ) + ) + ) +} + +# @a[*] +multi sub postcircumfix:<[ ]>( \SELF, Whatever:D ) is raw { + SELF[^SELF.elems]; +} +multi sub postcircumfix:<[ ]>( \SELF, Whatever:D, Mu \assignee ) is raw { + SELF[^SELF.elems] = assignee; +} +multi sub postcircumfix:<[ ]>(\SELF, Whatever:D, :$BIND!) is raw { + X::Bind::Slice.new(type => SELF.WHAT).throw; +} +multi sub postcircumfix:<[ ]>(\SELF, Whatever:D, :$delete!, *%other) is raw { + SLICE_MORE_LIST( SELF, ^SELF.elems, 'delete', $delete, %other ); +} +multi sub postcircumfix:<[ ]>(\SELF, Whatever:D, :$exists!, *%other) is raw { + SLICE_MORE_LIST( SELF, ^SELF.elems, 'exists', $exists, %other ); +} +multi sub postcircumfix:<[ ]>(\SELF, Whatever:D, :$kv!, *%other) is raw { + SLICE_MORE_LIST( SELF, ^SELF.elems, 'kv', $kv, %other ); +} +multi sub postcircumfix:<[ ]>(\SELF, Whatever:D, :$p!, *%other) is raw { + SLICE_MORE_LIST( SELF, ^SELF.elems, 'p', $p, %other ); +} +multi sub postcircumfix:<[ ]>(\SELF, Whatever:D, :$k!, *%other) is raw { + SLICE_MORE_LIST( SELF, ^SELF.elems, 'k', $k, %other ); +} +multi sub postcircumfix:<[ ]>(\SELF, Whatever:D, :$v!, *%other) is raw { + nqp::elems(nqp::getattr(%other,Map,'$!storage')) + ?? SLICE_MORE_LIST( SELF, ^SELF.elems, 'v', $v, %other ) + !! SELF[^SELF.elems]; +} + +# @a[**] +multi sub postcircumfix:<[ ]>(\SELF, HyperWhatever:D $, *%adv) is raw { + X::NYI.new(feature => 'HyperWhatever in array index').throw; +} +multi sub postcircumfix:<[ ]>(\SELF, HyperWhatever:D $, Mu \assignee) is raw { + X::NYI.new(feature => 'HyperWhatever in array index').throw; +} + +# @a[] +multi sub postcircumfix:<[ ]>(\SELF, :$BIND!) is raw { + X::Bind::ZenSlice.new(type => SELF.WHAT).throw; +} +multi sub postcircumfix:<[ ]>(\SELF, :$delete!, *%other) is raw { + SLICE_MORE_LIST( SELF, ^SELF.elems, 'delete', $delete, %other ); +} +multi sub postcircumfix:<[ ]>(\SELF, :$exists!, *%other) is raw { + SLICE_MORE_LIST( SELF, ^SELF.elems, 'exists', $exists, %other ); +} +multi sub postcircumfix:<[ ]>(\SELF, :$kv!, *%other) is raw { + SLICE_MORE_LIST( SELF, ^SELF.elems, 'kv', $kv, %other ); +} +multi sub postcircumfix:<[ ]>(\SELF, :$p!, *%other) is raw { + SLICE_MORE_LIST( SELF, ^SELF.elems, 'p', $p, %other ); +} +multi sub postcircumfix:<[ ]>(\SELF, :$k!, *%other) is raw { + SLICE_MORE_LIST( SELF, ^SELF.elems, 'k', $k, %other ); +} +multi sub postcircumfix:<[ ]>(\SELF, :$v!, *%other) is raw { + nqp::elems(nqp::getattr(%other,Map,'$!storage')) + ?? SLICE_MORE_LIST( SELF, ^SELF.elems, 'v', $v, %other ) + !! SELF[^SELF.elems]; +} +multi sub postcircumfix:<[ ]>(\SELF, *%other) is raw { + SELF.ZEN-POS(|%other); +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Associative.pm rakudo-2018.03/src/core/Associative.pm --- rakudo-2018.02.1/src/core/Associative.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Associative.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -my role Associative[::TValue = Mu, ::TKey = Str(Any)] { - method of() { TValue } - method keyof() { TKey } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Associative.pm6 rakudo-2018.03/src/core/Associative.pm6 --- rakudo-2018.02.1/src/core/Associative.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Associative.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,6 @@ +my role Associative[::TValue = Mu, ::TKey = Str(Any)] { + method of() { TValue } + method keyof() { TKey } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/AST.pm rakudo-2018.03/src/core/AST.pm --- rakudo-2018.02.1/src/core/AST.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/AST.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -# XXX: Would like to have this class as Perl6::AST, but ran up against -# problems with the serialization context calling it that. -my class AST { - has $!past; - has $!quasi_context; - has $!Str; - - submethod BUILD(:$past --> Nil) { $!past := $past } - - method incarnate($quasi_context, @unquote_asts) { - my $incarnation = self.clone(); - nqp::bindattr(nqp::decont($incarnation), AST, '$!past', $incarnation.evaluate_unquotes(@unquote_asts)); - nqp::bindattr(nqp::decont($incarnation), AST, '$!quasi_context', $quasi_context); - $incarnation; - } - - method evaluate_unquotes(@unquote_asts) { - my $pasts := nqp::list(); - for @unquote_asts { - # TODO: find and report macro name - X::TypeCheck::Splice.new( - got => $_, - expected => AST, - action => 'unquote evaluation', - ).throw unless nqp::istype($_,AST); - nqp::push($pasts, nqp::getattr(nqp::decont($_), AST, '$!past')) - } - $!past.evaluate_unquotes($pasts); - } - - method is_quasi_ast { - so $!quasi_context; - } - - method Str { - $!Str; - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/AST.pm6 rakudo-2018.03/src/core/AST.pm6 --- rakudo-2018.02.1/src/core/AST.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/AST.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,40 @@ +# XXX: Would like to have this class as Perl6::AST, but ran up against +# problems with the serialization context calling it that. +my class AST { + has $!past; + has $!quasi_context; + has $!Str; + + submethod BUILD(:$past --> Nil) { $!past := $past } + + method incarnate($quasi_context, @unquote_asts) { + my $incarnation = self.clone(); + nqp::bindattr(nqp::decont($incarnation), AST, '$!past', $incarnation.evaluate_unquotes(@unquote_asts)); + nqp::bindattr(nqp::decont($incarnation), AST, '$!quasi_context', $quasi_context); + $incarnation; + } + + method evaluate_unquotes(@unquote_asts) { + my $pasts := nqp::list(); + for @unquote_asts { + # TODO: find and report macro name + X::TypeCheck::Splice.new( + got => $_, + expected => AST, + action => 'unquote evaluation', + ).throw unless nqp::istype($_,AST); + nqp::push($pasts, nqp::getattr(nqp::decont($_), AST, '$!past')) + } + $!past.evaluate_unquotes($pasts); + } + + method is_quasi_ast { + so $!quasi_context; + } + + method Str { + $!Str; + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/asyncops.pm rakudo-2018.03/src/core/asyncops.pm --- rakudo-2018.02.1/src/core/asyncops.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/asyncops.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,84 +0,0 @@ -# Waits for a promise to be kept or a channel to be able to receive a value -# and, once it can, unwraps or returns the result. Under Perl 6.c, await will -# really block the calling thread. In 6.d, if the thread is on the thread pool -# then a continuation will be taken, and the thread is freed up. - -my role X::Await::Died { - has $.await-backtrace; - multi method gist(::?CLASS:D:) { - "An operation first awaited:\n" ~ - ((try $!await-backtrace ~ "\n") // '') ~ - "Died with the exception:\n" ~ - callsame().indent(4) - } -} - -proto sub await(|) {*} -multi sub await() { - die "Must specify a Promise or Channel to await on (got an empty list)"; -} -multi sub await(Any:U $x) { - die "Must specify a defined Promise, Channel, or Supply to await on (got an undefined $x.^name())"; -} -multi sub await(Any:D $x) { - die "Must specify a Promise, Channel, or Supply to await on (got a $x.^name())"; -} -multi sub await(Promise:D $p) { - CATCH { - unless nqp::istype($_, X::Await::Died) { - ($_ but X::Await::Died(Backtrace.new(5))).rethrow - } - } - my $*RAKUDO-AWAIT-BLOCKING := True; - $*AWAITER.await($p) -} -multi sub await(Channel:D $c) { - CATCH { - unless nqp::istype($_, X::Await::Died) { - ($_ but X::Await::Died(Backtrace.new(5))).rethrow - } - } - my $*RAKUDO-AWAIT-BLOCKING := True; - $*AWAITER.await($c) -} -multi sub await(Supply:D $s) { - CATCH { - unless nqp::istype($_, X::Await::Died) { - ($_ but X::Await::Died(Backtrace.new(5))).rethrow - } - } - my $*RAKUDO-AWAIT-BLOCKING := True; - $*AWAITER.await($s) -} -multi sub await(Iterable:D $i) { eager $i.eager.map({ await $_ }) } -multi sub await(*@awaitables) { eager @awaitables.eager.map({await $_}) } - -sub awaiterator(@promises) { - Seq.new(class :: does Iterator { - has @!todo; - has @!done; - method !SET-SELF(\todo) { @!todo = todo; self } - method new(\todo) { nqp::create(self)!SET-SELF(todo) } - method pull-one() is raw { - if @!done { - @!done.shift - } - elsif @!todo { - Promise.anyof(@!todo).result; - my @next; - .status == Planned - ?? @next.push($_) - !! @!done.push($_.result) - for @!todo; - @!todo := @next; - @!done.shift - } - else { - IterationEnd - } - } - method sink-all(--> IterationEnd) { Promise.allof(@promises).result } - }.new(@promises)) -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/asyncops.pm6 rakudo-2018.03/src/core/asyncops.pm6 --- rakudo-2018.02.1/src/core/asyncops.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/asyncops.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,84 @@ +# Waits for a promise to be kept or a channel to be able to receive a value +# and, once it can, unwraps or returns the result. Under Perl 6.c, await will +# really block the calling thread. In 6.d, if the thread is on the thread pool +# then a continuation will be taken, and the thread is freed up. + +my role X::Await::Died { + has $.await-backtrace; + multi method gist(::?CLASS:D:) { + "An operation first awaited:\n" ~ + ((try $!await-backtrace ~ "\n") // '') ~ + "Died with the exception:\n" ~ + callsame().indent(4) + } +} + +proto sub await(|) {*} +multi sub await() { + die "Must specify a Promise or Channel to await on (got an empty list)"; +} +multi sub await(Any:U $x) { + die "Must specify a defined Promise, Channel, or Supply to await on (got an undefined $x.^name())"; +} +multi sub await(Any:D $x) { + die "Must specify a Promise, Channel, or Supply to await on (got a $x.^name())"; +} +multi sub await(Promise:D $p) { + CATCH { + unless nqp::istype($_, X::Await::Died) { + ($_ but X::Await::Died(Backtrace.new(5))).rethrow + } + } + my $*RAKUDO-AWAIT-BLOCKING := True; + $*AWAITER.await($p) +} +multi sub await(Channel:D $c) { + CATCH { + unless nqp::istype($_, X::Await::Died) { + ($_ but X::Await::Died(Backtrace.new(5))).rethrow + } + } + my $*RAKUDO-AWAIT-BLOCKING := True; + $*AWAITER.await($c) +} +multi sub await(Supply:D $s) { + CATCH { + unless nqp::istype($_, X::Await::Died) { + ($_ but X::Await::Died(Backtrace.new(5))).rethrow + } + } + my $*RAKUDO-AWAIT-BLOCKING := True; + $*AWAITER.await($s) +} +multi sub await(Iterable:D $i) { eager $i.eager.map({ await $_ }) } +multi sub await(*@awaitables) { eager @awaitables.eager.map({await $_}) } + +sub awaiterator(@promises) { + Seq.new(class :: does Iterator { + has @!todo; + has @!done; + method !SET-SELF(\todo) { @!todo = todo; self } + method new(\todo) { nqp::create(self)!SET-SELF(todo) } + method pull-one() is raw { + if @!done { + @!done.shift + } + elsif @!todo { + Promise.anyof(@!todo).result; + my @next; + .status == Planned + ?? @next.push($_) + !! @!done.push($_.result) + for @!todo; + @!todo := @next; + @!done.shift + } + else { + IterationEnd + } + } + method sink-all(--> IterationEnd) { Promise.allof(@promises).result } + }.new(@promises)) +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/atomicops.pm rakudo-2018.03/src/core/atomicops.pm --- rakudo-2018.02.1/src/core/atomicops.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/atomicops.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,209 +0,0 @@ -#-- fetching a value atomically -proto sub atomic-fetch($) {*} -multi sub atomic-fetch($source is rw) { - nqp::atomicload($source) -} - -proto sub prefix:<⚛>($) {*} -multi sub prefix:<⚛>($source is rw) { - nqp::atomicload($source) -} - -#-- assigning a value atomically -proto sub atomic-assign($, $) {*} -multi sub atomic-assign($target is rw, \value) { - nqp::atomicstore($target, value) -} - -#-- atomic compare and swap -proto sub cas(|) {*} -multi sub cas($target is rw, \expected, \value) { - nqp::cas($target, expected, value) -} -multi sub cas($target is rw, &code) { - my $current := nqp::atomicload($target); - loop { - my $updated := code($current); - my $seen := nqp::cas($target, $current, $updated); - return $updated if nqp::eqaddr($seen, $current); - $current := $seen; - } -} - -# Native integer atomics only available on MoarVM -#?if moar -my native atomicint is repr('P6int') is Int is ctype('atomic') { } - -#-- fetching a value atomically -multi sub atomic-fetch(atomicint $source is rw) { - nqp::atomicload_i($source) -} - -multi sub prefix:<⚛>(atomicint $source is rw) { - nqp::atomicload_i($source) -} - -#-- assigning a value atomically -multi sub atomic-assign(atomicint $target is rw, int $value) { - nqp::atomicstore_i($target, $value) -} -multi sub atomic-assign(atomicint $target is rw, Int:D $value) { - nqp::atomicstore_i($target, $value) -} -multi sub atomic-assign(atomicint $target is rw, $value) { - nqp::atomicstore_i($target, $value.Int) -} - -proto sub infix:<⚛=>($, $) {*} -multi sub infix:<⚛=>($target is rw, \value) { - nqp::atomicstore($target, value) -} -multi sub infix:<⚛=>(atomicint $target is rw, int $value) { - nqp::atomicstore_i($target, $value) -} -multi sub infix:<⚛=>(atomicint $target is rw, Int:D $value) { - nqp::atomicstore_i($target, $value) -} -multi sub infix:<⚛=>(atomicint $target is rw, $value) { - nqp::atomicstore_i($target, $value.Int) -} - -#-- atomically fetch value and increment it -sub atomic-fetch-inc(atomicint $target is rw --> atomicint) { - nqp::atomicinc_i($target) -} - -sub postfix:<⚛++>(atomicint $target is rw --> atomicint) { - nqp::atomicinc_i($target) -} - -#-- atomically increment value and fetch it -sub atomic-inc-fetch(atomicint $target is rw --> atomicint) { - my atomicint $ = nqp::atomicinc_i($target) + 1 -} -sub prefix:<++⚛>(atomicint $target is rw --> atomicint) { - my atomicint $ = nqp::atomicinc_i($target) + 1 -} - -#-- atomically fetch value and decrement it -sub atomic-fetch-dec(atomicint $target is rw --> atomicint) { - nqp::atomicdec_i($target) -} - -sub postfix:<⚛-->(atomicint $target is rw --> atomicint) { - nqp::atomicdec_i($target) -} - -#-- atomically decrement value and fetch it -sub atomic-dec-fetch(atomicint $target is rw --> atomicint) { - my atomicint $ = nqp::atomicdec_i($target) - 1 -} -sub prefix:<--⚛>(atomicint $target is rw --> atomicint) { - my atomicint $ = nqp::atomicdec_i($target) - 1 -} - -#-- atomically fetch value and then add given value to it -proto sub atomic-fetch-add($, $) {*} -multi sub atomic-fetch-add(atomicint $target is rw, int $add --> atomicint) { - nqp::atomicadd_i($target, $add) -} -multi sub atomic-fetch-add(atomicint $target is rw, Int:D $add --> atomicint) { - nqp::atomicadd_i($target, $add) -} -multi sub atomic-fetch-add(atomicint $target is rw, $add --> atomicint) { - nqp::atomicadd_i($target, $add.Int) -} - -#-- atomically add given value to value and return that -proto sub atomic-add-fetch($, $) {*} -multi sub atomic-add-fetch(atomicint $target is rw, int $add --> atomicint) { - my atomicint $ = nqp::atomicadd_i($target, $add) + $add -} -multi sub atomic-add-fetch(atomicint $target is rw, Int:D $add --> atomicint) { - my atomicint $ = nqp::atomicadd_i($target, $add) + $add -} -multi sub atomic-add-fetch(atomicint $target is rw, $add --> atomicint) { - my int $add-int = $add.Int; - my atomicint $ = nqp::atomicadd_i($target, $add-int) + $add-int -} - -proto sub infix:<⚛+=>($, $) {*} -multi sub infix:<⚛+=>(atomicint $target is rw, int $add --> atomicint) { - my atomicint $ = nqp::atomicadd_i($target, $add) + $add -} -multi sub infix:<⚛+=>(atomicint $target is rw, Int:D $add --> atomicint) { - my atomicint $ = nqp::atomicadd_i($target, $add) + $add -} -multi sub infix:<⚛+=>(atomicint $target is rw, $add --> atomicint) { - my int $add-int = $add.Int; - my atomicint $ = nqp::atomicadd_i($target, $add-int) + $add-int -} - -#-- atomically fetch value and then subtract given value from it -proto sub atomic-fetch-sub($, $) {*} -multi sub atomic-fetch-sub(atomicint $target is rw, int $add --> atomicint) { - nqp::atomicadd_i($target, nqp::neg_i($add)) -} -multi sub atomic-fetch-sub(atomicint $target is rw, Int:D $add --> atomicint) { - nqp::atomicadd_i($target, nqp::neg_i($add)) -} -multi sub atomic-fetch-sub(atomicint $target is rw, $add --> atomicint) { - nqp::atomicadd_i($target, nqp::neg_i($add.Int)) -} - -#-- atomically subtract given value from value and return that -proto sub atomic-sub-fetch($, $) {*} -multi sub atomic-sub-fetch(atomicint $target is rw, int $add --> atomicint) { - my atomicint $ = nqp::atomicadd_i($target, nqp::neg_i($add)) - $add -} -multi sub atomic-sub-fetch(atomicint $target is rw, Int:D $add --> atomicint) { - my atomicint $ = nqp::atomicadd_i($target, nqp::neg_i($add)) - $add -} -multi sub atomic-sub-fetch(atomicint $target is rw, $add --> atomicint) { - my int $add-int = nqp::neg_i($add.Int); - my atomicint $ = nqp::atomicadd_i($target, $add-int) + $add-int -} - -proto sub infix:<⚛-=>($, $) {*} -multi sub infix:<⚛-=>(atomicint $target is rw, int $add --> atomicint) { - my atomicint $ = nqp::atomicadd_i($target, nqp::neg_i($add)) - $add -} -multi sub infix:<⚛-=>(atomicint $target is rw, Int:D $add --> atomicint) { - my atomicint $ = nqp::atomicadd_i($target, nqp::neg_i($add)) - $add -} -multi sub infix:<⚛-=>(atomicint $target is rw, $add --> atomicint) { - my int $add-int = nqp::neg_i($add.Int); - my atomicint $ = nqp::atomicadd_i($target, $add-int) + $add-int -} -my constant &infix:<⚛−=> := &infix:<⚛-=>; - -#-- provide full barrier semantics -sub full-barrier(--> Nil) { - nqp::barrierfull() -} - -#-- atomic compare and swap -multi sub cas(atomicint $target is rw, int $expected, int $value) { - nqp::cas_i($target, $expected, $value) -} - -multi sub cas(atomicint $target is rw, Int:D $expected, Int:D $value) { - nqp::cas_i($target, $expected, $value) -} - -multi sub cas(atomicint $target is rw, $expected, $value) { - nqp::cas_i($target, $expected.Int, $value.Int) -} - -multi sub cas(atomicint $target is rw, &code) { - my int $current = nqp::atomicload_i($target); - loop { - my int $updated = code($current); - my int $seen = nqp::cas_i($target, $current, $updated); - return $updated if $seen == $current; - $current = $seen; - } -} -#?endif - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/atomicops.pm6 rakudo-2018.03/src/core/atomicops.pm6 --- rakudo-2018.02.1/src/core/atomicops.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/atomicops.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,220 @@ +#== Atomics available on all backends ============================================ + +#-- fetching a value atomically +proto sub atomic-fetch($) {*} +multi sub atomic-fetch($source is rw) { + nqp::atomicload($source) +} + +proto sub prefix:<⚛>($) {*} +multi sub prefix:<⚛>($source is rw) { + nqp::atomicload($source) +} + +#-- assigning a value atomically +proto sub atomic-assign($, $) {*} +multi sub atomic-assign($target is rw, \value) { + nqp::atomicstore($target, value) +} + +#-- atomic compare and swap +proto sub cas(|) {*} +multi sub cas($target is rw, \expected, \value) { + nqp::cas($target, expected, value) +} +multi sub cas($target is rw, &code) { + my $current := nqp::atomicload($target); + loop { + my $updated := code($current); + my $seen := nqp::cas($target, $current, $updated); + return $updated if nqp::eqaddr($seen, $current); + $current := $seen; + } +} + +#== Native integer atomics only available on MoarVM ============================== + +#?if moar +my native atomicint is repr('P6int') is Int is ctype('atomic') { } + +#-- fetching a native integer value atomically +multi sub atomic-fetch(atomicint $source is rw) { + nqp::atomicload_i($source) +} + +multi sub prefix:<⚛>(atomicint $source is rw) { + nqp::atomicload_i($source) +} + +#-- assigning a native integer value atomically +multi sub atomic-assign(atomicint $target is rw, int $value) { + nqp::atomicstore_i($target, $value) +} +multi sub atomic-assign(atomicint $target is rw, Int:D $value) { + nqp::atomicstore_i($target, $value) +} +multi sub atomic-assign(atomicint $target is rw, $value) { + nqp::atomicstore_i($target, $value.Int) +} + +proto sub infix:<⚛=>($, $) {*} +multi sub infix:<⚛=>($target is rw, \value) { + nqp::atomicstore($target, value) +} +multi sub infix:<⚛=>(atomicint $target is rw, int $value) { + nqp::atomicstore_i($target, $value) +} +multi sub infix:<⚛=>(atomicint $target is rw, Int:D $value) { + nqp::atomicstore_i($target, $value) +} +multi sub infix:<⚛=>(atomicint $target is rw, $value) { + nqp::atomicstore_i($target, $value.Int) +} + +#-- atomically fetch native integer value and increment it +proto sub atomic-fetch-inc(|) {*} +multi sub atomic-fetch-inc(atomicint $target is rw --> atomicint) { + nqp::atomicinc_i($target) +} + +proto sub postfix:<⚛++>(|) {*} +multi sub postfix:<⚛++>(atomicint $target is rw --> atomicint) { + nqp::atomicinc_i($target) +} + +#-- atomically increment native integer value and fetch it +proto sub atomic-inc-fetch(|) {*} +multi sub atomic-inc-fetch(atomicint $target is rw --> atomicint) { + my atomicint $ = nqp::atomicinc_i($target) + 1 +} + +proto sub prefix:<++⚛>(|) {*} +multi sub prefix:<++⚛>(atomicint $target is rw --> atomicint) { + my atomicint $ = nqp::atomicinc_i($target) + 1 +} + +#-- atomically fetch native integer value and decrement it +proto sub atomic-fetch-dec(|) {*} +multi sub atomic-fetch-dec(atomicint $target is rw --> atomicint) { + nqp::atomicdec_i($target) +} + +proto sub postfix:<⚛-->(|) {*} +multi sub postfix:<⚛-->(atomicint $target is rw --> atomicint) { + nqp::atomicdec_i($target) +} + +#-- atomically decrement native integer value and fetch it +proto sub atomic-dec-fetch(|) {*} +multi sub atomic-dec-fetch(atomicint $target is rw --> atomicint) { + my atomicint $ = nqp::atomicdec_i($target) - 1 +} + +proto sub prefix:<--⚛>(|) {*} +multi sub prefix:<--⚛>(atomicint $target is rw --> atomicint) { + my atomicint $ = nqp::atomicdec_i($target) - 1 +} + +#-- atomically fetch native integer value and then add given value to it +proto sub atomic-fetch-add($, $) {*} +multi sub atomic-fetch-add(atomicint $target is rw, int $add --> atomicint) { + nqp::atomicadd_i($target, $add) +} +multi sub atomic-fetch-add(atomicint $target is rw, Int:D $add --> atomicint) { + nqp::atomicadd_i($target, $add) +} +multi sub atomic-fetch-add(atomicint $target is rw, $add --> atomicint) { + nqp::atomicadd_i($target, $add.Int) +} + +#-- atomically add given native integer value to value and return that +proto sub atomic-add-fetch($, $) {*} +multi sub atomic-add-fetch(atomicint $target is rw, int $add --> atomicint) { + my atomicint $ = nqp::atomicadd_i($target, $add) + $add +} +multi sub atomic-add-fetch(atomicint $target is rw, Int:D $add --> atomicint) { + my atomicint $ = nqp::atomicadd_i($target, $add) + $add +} +multi sub atomic-add-fetch(atomicint $target is rw, $add --> atomicint) { + my int $add-int = $add.Int; + my atomicint $ = nqp::atomicadd_i($target, $add-int) + $add-int +} + +proto sub infix:<⚛+=>($, $) {*} +multi sub infix:<⚛+=>(atomicint $target is rw, int $add --> atomicint) { + my atomicint $ = nqp::atomicadd_i($target, $add) + $add +} +multi sub infix:<⚛+=>(atomicint $target is rw, Int:D $add --> atomicint) { + my atomicint $ = nqp::atomicadd_i($target, $add) + $add +} +multi sub infix:<⚛+=>(atomicint $target is rw, $add --> atomicint) { + my int $add-int = $add.Int; + my atomicint $ = nqp::atomicadd_i($target, $add-int) + $add-int +} + +#-- atomically fetch native integer value and then subtract given value from it +proto sub atomic-fetch-sub($, $) {*} +multi sub atomic-fetch-sub(atomicint $target is rw, int $add --> atomicint) { + nqp::atomicadd_i($target, nqp::neg_i($add)) +} +multi sub atomic-fetch-sub(atomicint $target is rw, Int:D $add --> atomicint) { + nqp::atomicadd_i($target, nqp::neg_i($add)) +} +multi sub atomic-fetch-sub(atomicint $target is rw, $add --> atomicint) { + nqp::atomicadd_i($target, nqp::neg_i($add.Int)) +} + +#-- atomically subtract given native integer value from value and return that +proto sub atomic-sub-fetch($, $) {*} +multi sub atomic-sub-fetch(atomicint $target is rw, int $add --> atomicint) { + my atomicint $ = nqp::atomicadd_i($target, nqp::neg_i($add)) - $add +} +multi sub atomic-sub-fetch(atomicint $target is rw, Int:D $add --> atomicint) { + my atomicint $ = nqp::atomicadd_i($target, nqp::neg_i($add)) - $add +} +multi sub atomic-sub-fetch(atomicint $target is rw, $add --> atomicint) { + my int $add-int = nqp::neg_i($add.Int); + my atomicint $ = nqp::atomicadd_i($target, $add-int) + $add-int +} + +proto sub infix:<⚛-=>($, $) {*} +multi sub infix:<⚛-=>(atomicint $target is rw, int $add --> atomicint) { + my atomicint $ = nqp::atomicadd_i($target, nqp::neg_i($add)) - $add +} +multi sub infix:<⚛-=>(atomicint $target is rw, Int:D $add --> atomicint) { + my atomicint $ = nqp::atomicadd_i($target, nqp::neg_i($add)) - $add +} +multi sub infix:<⚛-=>(atomicint $target is rw, $add --> atomicint) { + my int $add-int = nqp::neg_i($add.Int); + my atomicint $ = nqp::atomicadd_i($target, $add-int) + $add-int +} +my constant &infix:<⚛−=> := &infix:<⚛-=>; + +#-- provide full barrier semantics +proto sub full-barrier(|) {*} +multi sub full-barrier(--> Nil) { + nqp::barrierfull() +} + +#-- atomic compare and swap a native integer +multi sub cas(atomicint $target is rw, int $expected, int $value) { + nqp::cas_i($target, $expected, $value) +} +multi sub cas(atomicint $target is rw, Int:D $expected, Int:D $value) { + nqp::cas_i($target, $expected, $value) +} +multi sub cas(atomicint $target is rw, $expected, $value) { + nqp::cas_i($target, $expected.Int, $value.Int) +} +multi sub cas(atomicint $target is rw, &code) { + my int $current = nqp::atomicload_i($target); + loop { + my int $updated = code($current); + my int $seen = nqp::cas_i($target, $current, $updated); + return $updated if $seen == $current; + $current = $seen; + } +} +#?endif + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Attribute.pm rakudo-2018.03/src/core/Attribute.pm --- rakudo-2018.02.1/src/core/Attribute.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Attribute.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,165 +0,0 @@ -my class Attribute { # declared in BOOTSTRAP - # class Attribute is Any - # has str $!name; - # has int $!rw; - # has int $!has_accessor; - # has Mu $!type; - # has Mu $!container_descriptor; - # has Mu $!auto_viv_container; - # has Mu $!build_closure; - # has Mu $!package; - # has int $!inlined; - # has int $!positional_delegate; - # has int $!associative_delegate; - # has Mu $!why; - # has $!required; - # has Mu $!container_initializer; - - method compose(Mu $package, :$compiler_services) { - # Generate accessor method, if we're meant to have one. - if self.has_accessor { - my str $name = nqp::unbox_s(self.name); - my $meth_name := nqp::substr($name, 2); - unless $package.^declares_method($meth_name) { - my $dcpkg := nqp::decont($package); - my $meth; - my int $attr_type = nqp::objprimspec($!type); - - # Get the compiler to generate us an accessor when possible. - if $compiler_services.DEFINITE { - $meth := $compiler_services.generate_accessor($meth_name, - $dcpkg, $name, $!type, self.rw ?? 1 !! 0); - } - - # No compiler services available, so do it as a closure. - elsif self.rw { - $meth := nqp::p6bool(nqp::iseq_i($attr_type, 0)) - ?? - method (Mu:D \fles:) is raw { - nqp::getattr(nqp::decont(fles), $dcpkg, $name) - } - !! - nqp::p6bool(nqp::iseq_i($attr_type, 1)) - ?? - method (Mu:D \fles:) is raw { - nqp::getattrref_i(nqp::decont(fles), $dcpkg, $name) - } - !! - nqp::p6bool(nqp::iseq_i($attr_type, 2)) - ?? - method (Mu:D \fles:) is raw { - nqp::getattrref_n(nqp::decont(fles), $dcpkg, $name) - } - !! - method (Mu:D \fles:) is raw { - nqp::getattrref_s(nqp::decont(fles), $dcpkg, $name) - } - $meth.set_name($meth_name); - } else { - # ro accessor - $meth := nqp::p6bool(nqp::iseq_i($attr_type, 0)) - ?? - method (Mu:D \fles:) { - nqp::getattr(nqp::decont(fles), $dcpkg, $name) - } - !! - nqp::p6bool(nqp::iseq_i($attr_type, 1)) - ?? - method (Mu:D \fles:) { - nqp::p6box_i( - nqp::getattr_i(nqp::decont(fles), $dcpkg, $name) - ); - } - !! - nqp::p6bool(nqp::iseq_i($attr_type, 2)) - ?? - method (Mu:D \fles:) { - nqp::p6box_n( - nqp::getattr_n(nqp::decont(fles), $dcpkg, $name) - ); - } - !! - method (Mu:D \fles:) { - nqp::p6box_s( - nqp::getattr_s(nqp::decont(fles), $dcpkg, $name) - ); - } - $meth.set_name($meth_name); - } - $package.^add_method($meth_name, $meth); - } - } - - # Apply any handles trait we may have. - self.apply_handles($package); - } - - method apply_handles(Mu $pkg) { - # None by default. - } - - method get_value(Mu $obj) { - nqp::if( - nqp::iseq_i((my int $t = nqp::objprimspec($!type)),0), - nqp::getattr(nqp::decont($obj),$!package,$!name), - nqp::if( - nqp::iseq_i($t,1), - nqp::p6box_i(nqp::getattr_i(nqp::decont($obj),$!package,$!name)), - nqp::if( - nqp::iseq_i($t,2), - nqp::p6box_n(nqp::getattr_n(nqp::decont($obj), - $!package,$!name)), - nqp::if( - nqp::iseq_i($t,3), - nqp::p6box_s(nqp::getattr_s(nqp::decont($obj), - $!package,$!name)) - ) - ) - ) - ) - } - - method set_value(Mu $obj, Mu \value) { - nqp::if( - nqp::iseq_i((my int $t = nqp::objprimspec($!type)),0), - nqp::bindattr(nqp::decont($obj),$!package,$!name,value), - nqp::if( - nqp::iseq_i($t,1), - nqp::p6box_i(nqp::bindattr_i(nqp::decont($obj), - $!package,$!name,value)), - nqp::if( - nqp::iseq_i($t,2), - nqp::p6box_n(nqp::bindattr_n(nqp::decont($obj), - $!package,$!name,value)), - nqp::if( - nqp::iseq_i($t,3), - nqp::p6box_s(nqp::bindattr_s(nqp::decont($obj), - $!package,$!name,value)) - ) - ) - ) - ) - } - - method container() is raw { nqp::ifnull($!auto_viv_container,Nil) } - method readonly() { !self.rw } - method package() { $!package } - method inlined() { $!inlined } - multi method Str(Attribute:D:) { self.name } - multi method gist(Attribute:D:) { self.type.^name ~ " " ~ self.name } - - method WHY() { - if nqp::isnull($!why) { - nextsame - } else { - $!why.set_docee(self); - $!why - } - } - - method set_why($why) { - $!why := $why; - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Attribute.pm6 rakudo-2018.03/src/core/Attribute.pm6 --- rakudo-2018.02.1/src/core/Attribute.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Attribute.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,165 @@ +my class Attribute { # declared in BOOTSTRAP + # class Attribute is Any + # has str $!name; + # has int $!rw; + # has int $!has_accessor; + # has Mu $!type; + # has Mu $!container_descriptor; + # has Mu $!auto_viv_container; + # has Mu $!build_closure; + # has Mu $!package; + # has int $!inlined; + # has int $!positional_delegate; + # has int $!associative_delegate; + # has Mu $!why; + # has $!required; + # has Mu $!container_initializer; + + method compose(Mu $package, :$compiler_services) { + # Generate accessor method, if we're meant to have one. + if self.has_accessor { + my str $name = nqp::unbox_s(self.name); + my $meth_name := nqp::substr($name, 2); + unless $package.^declares_method($meth_name) { + my $dcpkg := nqp::decont($package); + my $meth; + my int $attr_type = nqp::objprimspec($!type); + + # Get the compiler to generate us an accessor when possible. + if $compiler_services.DEFINITE { + $meth := $compiler_services.generate_accessor($meth_name, + $dcpkg, $name, $!type, self.rw ?? 1 !! 0); + } + + # No compiler services available, so do it as a closure. + elsif self.rw { + $meth := nqp::p6bool(nqp::iseq_i($attr_type, 0)) + ?? + method (Mu:D \fles:) is raw { + nqp::getattr(nqp::decont(fles), $dcpkg, $name) + } + !! + nqp::p6bool(nqp::iseq_i($attr_type, 1)) + ?? + method (Mu:D \fles:) is raw { + nqp::getattrref_i(nqp::decont(fles), $dcpkg, $name) + } + !! + nqp::p6bool(nqp::iseq_i($attr_type, 2)) + ?? + method (Mu:D \fles:) is raw { + nqp::getattrref_n(nqp::decont(fles), $dcpkg, $name) + } + !! + method (Mu:D \fles:) is raw { + nqp::getattrref_s(nqp::decont(fles), $dcpkg, $name) + } + $meth.set_name($meth_name); + } else { + # ro accessor + $meth := nqp::p6bool(nqp::iseq_i($attr_type, 0)) + ?? + method (Mu:D \fles:) { + nqp::getattr(nqp::decont(fles), $dcpkg, $name) + } + !! + nqp::p6bool(nqp::iseq_i($attr_type, 1)) + ?? + method (Mu:D \fles:) { + nqp::p6box_i( + nqp::getattr_i(nqp::decont(fles), $dcpkg, $name) + ); + } + !! + nqp::p6bool(nqp::iseq_i($attr_type, 2)) + ?? + method (Mu:D \fles:) { + nqp::p6box_n( + nqp::getattr_n(nqp::decont(fles), $dcpkg, $name) + ); + } + !! + method (Mu:D \fles:) { + nqp::p6box_s( + nqp::getattr_s(nqp::decont(fles), $dcpkg, $name) + ); + } + $meth.set_name($meth_name); + } + $package.^add_method($meth_name, $meth); + } + } + + # Apply any handles trait we may have. + self.apply_handles($package); + } + + method apply_handles(Mu $pkg) { + # None by default. + } + + method get_value(Mu $obj) { + nqp::if( + nqp::iseq_i((my int $t = nqp::objprimspec($!type)),0), + nqp::getattr(nqp::decont($obj),$!package,$!name), + nqp::if( + nqp::iseq_i($t,1), + nqp::p6box_i(nqp::getattr_i(nqp::decont($obj),$!package,$!name)), + nqp::if( + nqp::iseq_i($t,2), + nqp::p6box_n(nqp::getattr_n(nqp::decont($obj), + $!package,$!name)), + nqp::if( + nqp::iseq_i($t,3), + nqp::p6box_s(nqp::getattr_s(nqp::decont($obj), + $!package,$!name)) + ) + ) + ) + ) + } + + method set_value(Mu $obj, Mu \value) { + nqp::if( + nqp::iseq_i((my int $t = nqp::objprimspec($!type)),0), + nqp::bindattr(nqp::decont($obj),$!package,$!name,value), + nqp::if( + nqp::iseq_i($t,1), + nqp::p6box_i(nqp::bindattr_i(nqp::decont($obj), + $!package,$!name,value)), + nqp::if( + nqp::iseq_i($t,2), + nqp::p6box_n(nqp::bindattr_n(nqp::decont($obj), + $!package,$!name,value)), + nqp::if( + nqp::iseq_i($t,3), + nqp::p6box_s(nqp::bindattr_s(nqp::decont($obj), + $!package,$!name,value)) + ) + ) + ) + ) + } + + method container() is raw { nqp::ifnull($!auto_viv_container,Nil) } + method readonly() { !self.rw } + method package() { $!package } + method inlined() { $!inlined } + multi method Str(Attribute:D:) { self.name } + multi method gist(Attribute:D:) { self.type.^name ~ " " ~ self.name } + + method WHY() { + if nqp::isnull($!why) { + nextsame + } else { + $!why.set_docee(self); + $!why + } + } + + method set_why($why) { + $!why := $why; + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Awaitable.pm rakudo-2018.03/src/core/Awaitable.pm --- rakudo-2018.02.1/src/core/Awaitable.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Awaitable.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,50 +0,0 @@ -# An Awaitable is something we can use the `await` operator on. To support -# this, it requires a `get-await-handle` method be implemented, which returns -# an `Awaitable::AwaitHandle`. -my role Awaitable { - method get-await-handle() { ... } -} - -# An Awaitable::Handle implementation is an immutable object that conveys the -# status of the requested asynchronous result at the point we obtain the -# handle. If the `.already` property is `True`, then there is no need to block -# or suspend execution; the `.result` or `.cause` of failure can be used right -# away (depending on the value of `.success). Otherwise, the consumer of the -# handle should call the `subscribe-awaiter` method with its unblock/resume -# handler, and then proceed to block/suspend. In this case, the handler will -# be passed two arguments: a `Bool` success, and a result/cause (result if -# success is `True`, cause if it's `False`). The `Awaitable::Handle` will -# *not* have its success/result/cause updated; this would open the door to -# data races (including subtle ones related to read/write ordering), when -# the point of the fast-path is to test if we've got a result already with -# minimal overhead (and thus minimal concurrency control). -my role Awaitable::Handle { - has Bool $.already; - has Bool $.success; - has Mu $.result; - has Exception $.cause; - - method already-success(Mu \result) { - nqp::create(self)!already-success(result) - } - method !already-success(Mu \result) { - $!already := True; - $!success := True; - $!result := result; - self - } - - method already-failure(Mu \cause) { - self.CREATE!already-failure(cause) - } - method !already-failure(Mu \cause) { - $!already := True; - $!success := False; - $!cause := cause; - self - } - - method subscribe-awaiter(&subscriber) { ... } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Awaitable.pm6 rakudo-2018.03/src/core/Awaitable.pm6 --- rakudo-2018.02.1/src/core/Awaitable.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Awaitable.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,50 @@ +# An Awaitable is something we can use the `await` operator on. To support +# this, it requires a `get-await-handle` method be implemented, which returns +# an `Awaitable::AwaitHandle`. +my role Awaitable { + method get-await-handle() { ... } +} + +# An Awaitable::Handle implementation is an immutable object that conveys the +# status of the requested asynchronous result at the point we obtain the +# handle. If the `.already` property is `True`, then there is no need to block +# or suspend execution; the `.result` or `.cause` of failure can be used right +# away (depending on the value of `.success). Otherwise, the consumer of the +# handle should call the `subscribe-awaiter` method with its unblock/resume +# handler, and then proceed to block/suspend. In this case, the handler will +# be passed two arguments: a `Bool` success, and a result/cause (result if +# success is `True`, cause if it's `False`). The `Awaitable::Handle` will +# *not* have its success/result/cause updated; this would open the door to +# data races (including subtle ones related to read/write ordering), when +# the point of the fast-path is to test if we've got a result already with +# minimal overhead (and thus minimal concurrency control). +my role Awaitable::Handle { + has Bool $.already; + has Bool $.success; + has Mu $.result; + has Exception $.cause; + + method already-success(Mu \result) { + nqp::create(self)!already-success(result) + } + method !already-success(Mu \result) { + $!already := True; + $!success := True; + $!result := result; + self + } + + method already-failure(Mu \cause) { + self.CREATE!already-failure(cause) + } + method !already-failure(Mu \cause) { + $!already := True; + $!success := False; + $!cause := cause; + self + } + + method subscribe-awaiter(&subscriber) { ... } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Awaiter.pm rakudo-2018.03/src/core/Awaiter.pm --- rakudo-2018.02.1/src/core/Awaiter.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Awaiter.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,115 +0,0 @@ -my role Awaiter { - method await(Awaitable:D $a) { ... } - method await-all(Iterable:D $i) { ... } -} - -my class Awaiter::Blocking does Awaiter { - method await(Awaitable:D $a) { - my $handle := $a.get-await-handle; - if $handle.already { - $handle.success - ?? $handle.result - !! $handle.cause.rethrow - } - else { - my $s = Semaphore.new(0); - my $success; - my $result; - $handle.subscribe-awaiter(-> \success, \result { - $success := success; - $result := result; - $s.release; - }); - $s.acquire; - $success - ?? $result - !! $result.rethrow - } - } - - method await-all(Iterable:D \i) { - # Collect results that are already available, and handles where the - # results are not yet available together with the matching insertion - # indices. - my \results = nqp::list(); - my \handles = nqp::list(); - my \indices = nqp::list_i(); - my int $insert = 0; - my $saw-slip = False; - for i -> $awaitable { - unless nqp::istype($awaitable, Awaitable) { - die "Can only specify Awaitable objects to await (got a $awaitable.^name())"; - } - unless nqp::isconcrete($awaitable) { - die "Must specify a defined Awaitable to await (got an undefined $awaitable.^name())"; - } - - my $handle := $awaitable.get-await-handle; - if $handle.already { - if $handle.success { - my \result = $handle.result; - nqp::bindpos(results, $insert, result); - $saw-slip = True if nqp::istype(result, Slip); - } - else { - $handle.cause.rethrow - } - } - else { - nqp::push(handles, $handle); - nqp::push_i(indices, $insert); - } - - ++$insert; - } - - # See if we have anything that we need to really block on. If so, we - # use a lock and condition variable to handle the blocking. The lock - # protects writes into the array. - my int $num-handles = nqp::elems(handles); - if $num-handles { - my $exception = Mu; - my $l = Lock.new; - my $ready = $l.condition(); - my int $remaining = $num-handles; - loop (my int $i = 0; $i < $num-handles; ++$i) { - my $handle := nqp::atpos(handles, $i); - my int $insert = nqp::atpos_i(indices, $i); - $handle.subscribe-awaiter(-> \success, \result { - $l.protect: { - if success && $remaining { - nqp::bindpos(results, $insert, result); - $saw-slip = True if nqp::istype(result, Slip); - --$remaining; - $ready.signal unless $remaining; - } - elsif !nqp::isconcrete($exception) { - $exception := result; - $remaining = 0; - $ready.signal; - } - } - }); - } - - # Block until remaining is 0 (need the loop to cope with suprious - # wakeups). - loop { - $l.protect: { - last if $remaining == 0; - $ready.wait; - } - } - - # If we got an exception, throw it. - $exception.rethrow if nqp::isconcrete($exception); - } - - my \result-list = nqp::p6bindattrinvres(nqp::create(List), List, '$!reified', results); - $saw-slip ?? result-list.map(-> \val { val }).List !! result-list - } -} - -PROCESS::<$AWAITER> := Awaiter::Blocking; - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Awaiter.pm6 rakudo-2018.03/src/core/Awaiter.pm6 --- rakudo-2018.02.1/src/core/Awaiter.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Awaiter.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,115 @@ +my role Awaiter { + method await(Awaitable:D $a) { ... } + method await-all(Iterable:D $i) { ... } +} + +my class Awaiter::Blocking does Awaiter { + method await(Awaitable:D $a) { + my $handle := $a.get-await-handle; + if $handle.already { + $handle.success + ?? $handle.result + !! $handle.cause.rethrow + } + else { + my $s = Semaphore.new(0); + my $success; + my $result; + $handle.subscribe-awaiter(-> \success, \result { + $success := success; + $result := result; + $s.release; + }); + $s.acquire; + $success + ?? $result + !! $result.rethrow + } + } + + method await-all(Iterable:D \i) { + # Collect results that are already available, and handles where the + # results are not yet available together with the matching insertion + # indices. + my \results = nqp::list(); + my \handles = nqp::list(); + my \indices = nqp::list_i(); + my int $insert = 0; + my $saw-slip = False; + for i -> $awaitable { + unless nqp::istype($awaitable, Awaitable) { + die "Can only specify Awaitable objects to await (got a $awaitable.^name())"; + } + unless nqp::isconcrete($awaitable) { + die "Must specify a defined Awaitable to await (got an undefined $awaitable.^name())"; + } + + my $handle := $awaitable.get-await-handle; + if $handle.already { + if $handle.success { + my \result = $handle.result; + nqp::bindpos(results, $insert, result); + $saw-slip = True if nqp::istype(result, Slip); + } + else { + $handle.cause.rethrow + } + } + else { + nqp::push(handles, $handle); + nqp::push_i(indices, $insert); + } + + ++$insert; + } + + # See if we have anything that we need to really block on. If so, we + # use a lock and condition variable to handle the blocking. The lock + # protects writes into the array. + my int $num-handles = nqp::elems(handles); + if $num-handles { + my $exception = Mu; + my $l = Lock.new; + my $ready = $l.condition(); + my int $remaining = $num-handles; + loop (my int $i = 0; $i < $num-handles; ++$i) { + my $handle := nqp::atpos(handles, $i); + my int $insert = nqp::atpos_i(indices, $i); + $handle.subscribe-awaiter(-> \success, \result { + $l.protect: { + if success && $remaining { + nqp::bindpos(results, $insert, result); + $saw-slip = True if nqp::istype(result, Slip); + --$remaining; + $ready.signal unless $remaining; + } + elsif !nqp::isconcrete($exception) { + $exception := result; + $remaining = 0; + $ready.signal; + } + } + }); + } + + # Block until remaining is 0 (need the loop to cope with suprious + # wakeups). + loop { + $l.protect: { + last if $remaining == 0; + $ready.wait; + } + } + + # If we got an exception, throw it. + $exception.rethrow if nqp::isconcrete($exception); + } + + my \result-list = nqp::p6bindattrinvres(nqp::create(List), List, '$!reified', results); + $saw-slip ?? result-list.map(-> \val { val }).List !! result-list + } +} + +PROCESS::<$AWAITER> := Awaiter::Blocking; + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Backtrace.pm rakudo-2018.03/src/core/Backtrace.pm --- rakudo-2018.02.1/src/core/Backtrace.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Backtrace.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,344 +0,0 @@ -my class Exception { ... } - -my class Backtrace { ... } -my class CompUnit::RepositoryRegistry is repr('Uninstantiable') { ... } - -my $RAKUDO-VERBOSE-STACKFRAME; - -my class Backtrace::Frame { - has Str $.file; - has Int $.line; - has Mu $.code; - has Str $.subname; - - method !SET-SELF($!file,$!line,\code,$!subname) { - $!code := code; - self - } - multi method new(Backtrace::Frame: \file,\line,\code,\subname) { - nqp::create(self)!SET-SELF(file,line,code,subname) - } - multi method new(Backtrace::Frame: |c) { - self.bless(|c) - } - - method subtype(Backtrace::Frame:D:) { - my $s = $!code.^name.lc.split('+', 2).cache[0]; - $s eq 'mu' ?? '' !! $s; - } - - method package(Backtrace::Frame:D:) { - $.code.package; - } - - multi method Str(Backtrace::Frame:D:) { - my $s = self.subtype; - $s ~= ' ' if $s.chars; - my $text = " in {$s}$.subname at {$.file} line $.line\n"; - - if $RAKUDO-VERBOSE-STACKFRAME -> $extra { - my $io = $!file.IO; - if $io.e { - my @lines = $io.lines; - my $from = max $!line - $extra, 1; - my $to = min $!line + $extra, +@lines; - for $from..$to -> $line { - my $star = $line == $!line ?? '*' !! ' '; - $text ~= "$line.fmt('%5d')$star @lines[$line - 1]\n"; - } - $text ~= "\n"; - } - } - $text; - } - - method is-hidden(Backtrace::Frame:D:) { - ?$!code.?is-hidden-from-backtrace - } - method is-routine(Backtrace::Frame:D:) { - nqp::p6bool(nqp::istype($!code,Routine)) - } - method is-setting(Backtrace::Frame:D:) { - $!file.starts-with("SETTING::") -#?if jvm - || $!file.ends-with("CORE.setting") -#?endif -#?if !jvm - || $!file.ends-with("CORE.setting." ~ Rakudo::Internals.PRECOMP-EXT) -#?endif - || $!file.ends-with(".nqp") - } -} - -my class Backtrace { - has Mu $!bt; - has Mu $!frames; - has Int $!bt-next; # next bt index to vivify - - method !SET-SELF($!bt,$!bt-next) { - once $RAKUDO-VERBOSE-STACKFRAME = - (%*ENV // 0).Num; - $!frames := nqp::list; - self - } - multi method new() { - try X::AdHoc.new(:payload("Died")).throw; - nqp::create(self)!SET-SELF( - nqp::backtrace(nqp::getattr(nqp::decont($!),Exception,'$!ex')), - 1) - } - multi method new(Int:D $offset) { - try X::AdHoc.new(:payload("Died")).throw; - nqp::create(self)!SET-SELF( - nqp::backtrace(nqp::getattr(nqp::decont($!),Exception,'$!ex')), - 1 + $offset) - } - multi method new(Mu \ex) { - nqp::create(self)!SET-SELF( - ex.^name eq 'BOOTException' - ?? nqp::backtrace(nqp::decont(ex)) - !! nqp::backtrace(nqp::getattr(nqp::decont(ex),Exception,'$!ex')), - 0) - } - multi method new(Mu \ex, Int:D $offset) { - nqp::create(self)!SET-SELF( - ex.^name eq 'BOOTException' - ?? nqp::backtrace(nqp::decont(ex)) - !! nqp::backtrace(nqp::getattr(nqp::decont(ex),Exception,'$!ex')), - $offset) - } - # note that backtraces are nqp::list()s, marshalled to us as a List - multi method new(List:D $bt) { - nqp::create(self)!SET-SELF($bt,0) - } - multi method new(List:D $bt, Int:D $offset) { - nqp::create(self)!SET-SELF($bt,$offset) - } - - method AT-POS($pos) { - return nqp::atpos($!frames,$pos) if nqp::existspos($!frames,$pos); - - my int $elems = $!bt.elems; - return Nil if $!bt-next >= $elems; # bt-next can init > elems - - my int $todo = $pos - nqp::elems($!frames) + 1; - return Nil if $todo < 1; # in case absurd $pos passed - while $!bt-next < $elems { - my $frame := $!bt.AT-POS($!bt-next++); - my $sub := $frame; - next unless defined $sub; - - my Mu $do := nqp::getattr(nqp::decont($sub), ForeignCode, '$!do'); - next if nqp::isnull($do); - - my $annotations := $frame; - next unless $annotations; - - my $file := $annotations; - next unless $file; - - if CompUnit::RepositoryRegistry.file-for-spec($file) -> $path { - $file := $path.absolute; - } - - next if $file.ends-with('BOOTSTRAP.nqp') - || $file.ends-with('QRegex.nqp') - || $file.ends-with('Perl6/Ops.nqp'); - if $file.ends-with('NQPHLL.nqp') || $file.ends-with('NQPHLL.moarvm') { - # This could mean we're at the end of the interesting backtrace, - # or it could mean that we're in something like sprintf (which - # uses an NQP grammar to parse the format string). - while $!bt-next < $elems { - my $frame := $!bt.AT-POS($!bt-next++); - my $annotations := $frame; - next unless $annotations; - my $file := $annotations; - next unless $file; - if $file.starts-with('SETTING::') { - $!bt-next--; # re-visit this frame - last; - } - } - next; - } - - my $line := $annotations; - next unless $line; - - my $name := nqp::p6box_s(nqp::getcodename($do)); - if $name eq 'handle-begin-time-exceptions' { - $!bt-next = $elems; - last; - } - - my $code; - try { - $code := nqp::getcodeobj($do); - $code := Any unless nqp::istype($code, Mu); - }; - - nqp::push($!frames, - Backtrace::Frame.new( - $file, - $line.Int, - $code, - $name.starts-with("_block") ?? '' !! $name, - ) - ); - last unless $todo = $todo - 1; - } - - # found something - if nqp::existspos($!frames,$pos) { - nqp::atpos($!frames,$pos); - } - - # we've reached the end, don't show the last if there is one - else { - nqp::pop($!frames) if $!frames; - Nil; - } - } - - method next-interesting-index(Backtrace:D: - Int $idx is copy = 0, :$named, :$noproto, :$setting) { - ++$idx; - - while self.AT-POS($idx++) -> $cand { - next if $cand.is-hidden; # hidden is never interesting - next if $noproto # no proto's please - && $cand.code.?is_dispatcher; # if a dispatcher - next if !$setting # no settings please - && $cand.is-setting; # and in setting - - my $n := $cand.subname; - next if $named && !$n; # only want named ones and no name - next if $n eq ''; # outer calling context - - return $idx - 1; - } - Nil; - } - - method outer-caller-idx(Backtrace:D: Int $startidx) { - - if self.AT-POS($startidx).code -> $start { - my %outers; - - my $current = $start.outer; - while $current.DEFINITE { - %outers{$current.static_id} = $start; - $current = $current.outer; - } - - my @outers; - my $i = $startidx; - while self.AT-POS($i++) -> $cand { - my $code = $cand.code; - next unless $code.DEFINITE && %outers{$code.static_id}.DEFINITE; - - @outers.push: $i - 1; - last if $cand.is-routine; - } - @outers; - } - - else { - $startidx.list; - } - } - - method nice(Backtrace:D: :$oneline) { - my $setting = %*ENV; - try { - my @frames; - my Int $i = self.next-interesting-index(-1); - while $i.defined { - $i = self.next-interesting-index($i, :$setting) if $oneline; - last unless $i.defined; - - my $prev = self.AT-POS($i); - if $prev.is-routine { - @frames.push: $prev; - } else { - my @outer_callers := self.outer-caller-idx($i); - my $target_idx = @outer_callers.keys.grep({self.AT-POS($i).code.^isa(Routine)})[0]; - $target_idx ||= @outer_callers[0] || $i; - my $current = self.AT-POS($target_idx); - @frames.append: $current.clone(line => $prev.line); - $i = $target_idx; - } - last if $oneline; - $i = self.next-interesting-index($i, :$setting); - } - CATCH { - default { - return ""; - } - } - @frames.join; - } - } - - multi method gist(Backtrace:D:) { - my $els := +self.list; - 'Backtrace(' ~ $els ~ ' frame' ~ 's' x ($els != 1) ~ ')' - } - multi method Str(Backtrace:D:) { self.nice } - multi method flat(Backtrace:D:) { self.list } - multi method map(Backtrace:D: &block) { - my $pos = 0; - gather while self.AT-POS($pos++) -> $cand { - take block($cand); - } - } - multi method first(Backtrace:D: Mu $test) { - my $pos = 0; - while self.AT-POS($pos++) -> $cand { - return-rw $cand if $cand ~~ $test; - } - Nil; - } - multi method list(Backtrace:D:) { - self.AT-POS(100); # will stop when done, do we need more than 100??? - nqp::p6bindattrinvres(nqp::create(List), List, '$!reified', $!frames) - } - - method first-none-setting-line(Backtrace:D:) { - (self.first({ !.is-hidden && !.is-setting }) // "\n").Str; - } - - method concise(Backtrace:D:) { - (self.grep({ !.is-hidden && .is-routine && !.is-setting }) // "\n").join; - } - - method full(Backtrace:D:) { self.list.join } - - method summary(Backtrace:D:) { - (self.grep({ !.is-hidden && (.is-routine || !.is-setting)}) // "\n").join; - } - - method is-runtime (Backtrace:D:) { - my $bt = $!bt; - for $bt.keys { - my $p6sub := $bt[$_]; - if nqp::istype($p6sub, ForeignCode) { - try { - my Mu $sub := nqp::getattr(nqp::decont($p6sub), ForeignCode, '$!do'); - my str $name = nqp::getcodename($sub); - return True if nqp::iseq_s($name, 'THREAD-ENTRY'); - return True if nqp::iseq_s($name, 'eval'); - return True if nqp::iseq_s($name, 'print_control'); - return False if nqp::iseq_s($name, 'compile'); - } - } - } - False; - } - -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Backtrace.pm6 rakudo-2018.03/src/core/Backtrace.pm6 --- rakudo-2018.02.1/src/core/Backtrace.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Backtrace.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,344 @@ +my class Exception { ... } + +my class Backtrace { ... } +my class CompUnit::RepositoryRegistry is repr('Uninstantiable') { ... } + +my $RAKUDO-VERBOSE-STACKFRAME; + +my class Backtrace::Frame { + has Str $.file; + has Int $.line; + has Mu $.code; + has Str $.subname; + + method !SET-SELF($!file,$!line,\code,$!subname) { + $!code := code; + self + } + multi method new(Backtrace::Frame: \file,\line,\code,\subname) { + nqp::create(self)!SET-SELF(file,line,code,subname) + } + multi method new(Backtrace::Frame: |c) { + self.bless(|c) + } + + method subtype(Backtrace::Frame:D:) { + my $s = $!code.^name.lc.split('+', 2).cache[0]; + $s eq 'mu' ?? '' !! $s; + } + + method package(Backtrace::Frame:D:) { + $.code.package; + } + + multi method Str(Backtrace::Frame:D:) { + my $s = self.subtype; + $s ~= ' ' if $s.chars; + my $text = " in {$s}$.subname at {$.file} line $.line\n"; + + if $RAKUDO-VERBOSE-STACKFRAME -> $extra { + my $io = $!file.IO; + if $io.e { + my @lines = $io.lines; + my $from = max $!line - $extra, 1; + my $to = min $!line + $extra, +@lines; + for $from..$to -> $line { + my $star = $line == $!line ?? '*' !! ' '; + $text ~= "$line.fmt('%5d')$star @lines[$line - 1]\n"; + } + $text ~= "\n"; + } + } + $text; + } + + method is-hidden(Backtrace::Frame:D:) { + ?$!code.?is-hidden-from-backtrace + } + method is-routine(Backtrace::Frame:D:) { + nqp::p6bool(nqp::istype($!code,Routine)) + } + method is-setting(Backtrace::Frame:D:) { + $!file.starts-with("SETTING::") +#?if jvm + || $!file.ends-with("CORE.setting") +#?endif +#?if !jvm + || $!file.ends-with("CORE.setting." ~ Rakudo::Internals.PRECOMP-EXT) +#?endif + || $!file.ends-with(".nqp") + } +} + +my class Backtrace { + has Mu $!bt; + has Mu $!frames; + has Int $!bt-next; # next bt index to vivify + + method !SET-SELF($!bt,$!bt-next) { + once $RAKUDO-VERBOSE-STACKFRAME = + (%*ENV // 0).Num; + $!frames := nqp::list; + self + } + multi method new() { + try X::AdHoc.new(:payload("Died")).throw; + nqp::create(self)!SET-SELF( + nqp::backtrace(nqp::getattr(nqp::decont($!),Exception,'$!ex')), + 1) + } + multi method new(Int:D $offset) { + try X::AdHoc.new(:payload("Died")).throw; + nqp::create(self)!SET-SELF( + nqp::backtrace(nqp::getattr(nqp::decont($!),Exception,'$!ex')), + 1 + $offset) + } + multi method new(Mu \ex) { + nqp::create(self)!SET-SELF( + ex.^name eq 'BOOTException' + ?? nqp::backtrace(nqp::decont(ex)) + !! nqp::backtrace(nqp::getattr(nqp::decont(ex),Exception,'$!ex')), + 0) + } + multi method new(Mu \ex, Int:D $offset) { + nqp::create(self)!SET-SELF( + ex.^name eq 'BOOTException' + ?? nqp::backtrace(nqp::decont(ex)) + !! nqp::backtrace(nqp::getattr(nqp::decont(ex),Exception,'$!ex')), + $offset) + } + # note that backtraces are nqp::list()s, marshalled to us as a List + multi method new(List:D $bt) { + nqp::create(self)!SET-SELF($bt,0) + } + multi method new(List:D $bt, Int:D $offset) { + nqp::create(self)!SET-SELF($bt,$offset) + } + + method AT-POS($pos) { + return nqp::atpos($!frames,$pos) if nqp::existspos($!frames,$pos); + + my int $elems = $!bt.elems; + return Nil if $!bt-next >= $elems; # bt-next can init > elems + + my int $todo = $pos - nqp::elems($!frames) + 1; + return Nil if $todo < 1; # in case absurd $pos passed + while $!bt-next < $elems { + my $frame := $!bt.AT-POS($!bt-next++); + my $sub := $frame; + next unless defined $sub; + + my Mu $do := nqp::getattr(nqp::decont($sub), ForeignCode, '$!do'); + next if nqp::isnull($do); + + my $annotations := $frame; + next unless $annotations; + + my $file := $annotations; + next unless $file; + + if CompUnit::RepositoryRegistry.file-for-spec($file) -> $path { + $file := $path.absolute; + } + + next if $file.ends-with('BOOTSTRAP.nqp') + || $file.ends-with('QRegex.nqp') + || $file.ends-with('Perl6/Ops.nqp'); + if $file.ends-with('NQPHLL.nqp') || $file.ends-with('NQPHLL.moarvm') { + # This could mean we're at the end of the interesting backtrace, + # or it could mean that we're in something like sprintf (which + # uses an NQP grammar to parse the format string). + while $!bt-next < $elems { + my $frame := $!bt.AT-POS($!bt-next++); + my $annotations := $frame; + next unless $annotations; + my $file := $annotations; + next unless $file; + if $file.starts-with('SETTING::') { + $!bt-next--; # re-visit this frame + last; + } + } + next; + } + + my $line := $annotations; + next unless $line; + + my $name := nqp::p6box_s(nqp::getcodename($do)); + if $name eq 'handle-begin-time-exceptions' { + $!bt-next = $elems; + last; + } + + my $code; + try { + $code := nqp::getcodeobj($do); + $code := Any unless nqp::istype($code, Mu); + }; + + nqp::push($!frames, + Backtrace::Frame.new( + $file, + $line.Int, + $code, + $name.starts-with("_block") ?? '' !! $name, + ) + ); + last unless $todo = $todo - 1; + } + + # found something + if nqp::existspos($!frames,$pos) { + nqp::atpos($!frames,$pos); + } + + # we've reached the end, don't show the last if there is one + else { + nqp::pop($!frames) if $!frames; + Nil; + } + } + + method next-interesting-index(Backtrace:D: + Int $idx is copy = 0, :$named, :$noproto, :$setting) { + ++$idx; + + while self.AT-POS($idx++) -> $cand { + next if $cand.is-hidden; # hidden is never interesting + next if $noproto # no proto's please + && $cand.code.?is_dispatcher; # if a dispatcher + next if !$setting # no settings please + && $cand.is-setting; # and in setting + + my $n := $cand.subname; + next if $named && !$n; # only want named ones and no name + next if $n eq ''; # outer calling context + + return $idx - 1; + } + Nil; + } + + method outer-caller-idx(Backtrace:D: Int $startidx) { + + if self.AT-POS($startidx).code -> $start { + my %outers; + + my $current = $start.outer; + while $current.DEFINITE { + %outers{$current.static_id} = $start; + $current = $current.outer; + } + + my @outers; + my $i = $startidx; + while self.AT-POS($i++) -> $cand { + my $code = $cand.code; + next unless $code.DEFINITE && %outers{$code.static_id}.DEFINITE; + + @outers.push: $i - 1; + last if $cand.is-routine; + } + @outers; + } + + else { + $startidx.list; + } + } + + method nice(Backtrace:D: :$oneline) { + my $setting = %*ENV; + try { + my @frames; + my Int $i = self.next-interesting-index(-1); + while $i.defined { + $i = self.next-interesting-index($i, :$setting) if $oneline; + last unless $i.defined; + + my $prev = self.AT-POS($i); + if $prev.is-routine { + @frames.push: $prev; + } else { + my @outer_callers := self.outer-caller-idx($i); + my $target_idx = @outer_callers.keys.grep({self.AT-POS($i).code.^isa(Routine)})[0]; + $target_idx ||= @outer_callers[0] || $i; + my $current = self.AT-POS($target_idx); + @frames.append: $current.clone(line => $prev.line); + $i = $target_idx; + } + last if $oneline; + $i = self.next-interesting-index($i, :$setting); + } + CATCH { + default { + return ""; + } + } + @frames.join; + } + } + + multi method gist(Backtrace:D:) { + my $els := +self.list; + 'Backtrace(' ~ $els ~ ' frame' ~ 's' x ($els != 1) ~ ')' + } + multi method Str(Backtrace:D:) { self.nice } + multi method flat(Backtrace:D:) { self.list } + multi method map(Backtrace:D: &block) { + my $pos = 0; + gather while self.AT-POS($pos++) -> $cand { + take block($cand); + } + } + multi method first(Backtrace:D: Mu $test) { + my $pos = 0; + while self.AT-POS($pos++) -> $cand { + return-rw $cand if $cand ~~ $test; + } + Nil; + } + multi method list(Backtrace:D:) { + self.AT-POS(100); # will stop when done, do we need more than 100??? + nqp::p6bindattrinvres(nqp::create(List), List, '$!reified', $!frames) + } + + method first-none-setting-line(Backtrace:D:) { + (self.first({ !.is-hidden && !.is-setting }) // "\n").Str; + } + + method concise(Backtrace:D:) { + (self.grep({ !.is-hidden && .is-routine && !.is-setting }) // "\n").join; + } + + method full(Backtrace:D:) { self.list.join } + + method summary(Backtrace:D:) { + (self.grep({ !.is-hidden && (.is-routine || !.is-setting)}) // "\n").join; + } + + method is-runtime (Backtrace:D:) { + my $bt = $!bt; + for $bt.keys { + my $p6sub := $bt[$_]; + if nqp::istype($p6sub, ForeignCode) { + try { + my Mu $sub := nqp::getattr(nqp::decont($p6sub), ForeignCode, '$!do'); + my str $name = nqp::getcodename($sub); + return True if nqp::iseq_s($name, 'THREAD-ENTRY'); + return True if nqp::iseq_s($name, 'eval'); + return True if nqp::iseq_s($name, 'print_control'); + return False if nqp::iseq_s($name, 'compile'); + } + } + } + False; + } + +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Baggy.pm rakudo-2018.03/src/core/Baggy.pm --- rakudo-2018.02.1/src/core/Baggy.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Baggy.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,727 +0,0 @@ -my role Baggy does QuantHash { - -# A Bag/BagHash/Mix/MixHash consists of a single hash with Pairs. -# The keys of the hash, are the .WHICH strings of the original object key. -# The values are Pairs containing the original object key and value. - - has Rakudo::Internals::IterationSet $!elems; # key.WHICH => (key,value) - -# The Baggy role takes care of all mutable and immutable aspects that are -# shared between Bag,BagHash,Mix,MixHash. Any specific behaviour for -# mutable and immutable aspects of Mix/MixHash need to live in Mixy. -# Immutables aspects of Bag/Mix, need to live to Bag/Mix respectively. - -#--- interface methods - multi method ACCEPTS(Baggy:U: \other --> Bool:D) { - other.^does(self) - } - multi method ACCEPTS(Baggy:D: Baggy:D \other --> Bool:D) { - nqp::p6bool( - nqp::unless( - nqp::eqaddr(self,other), - nqp::if( # not same object - (my $araw := $!elems), - nqp::if( # something on left - (my $braw := other.RAW-HASH), - nqp::if( # something on both sides - nqp::iseq_i(nqp::elems($araw),nqp::elems($braw)), - nqp::stmts( # same size - (my $iter := nqp::iterator($araw)), - nqp::while( - $iter, - nqp::unless( - nqp::getattr( - nqp::ifnull( - nqp::atkey($braw,nqp::iterkey_s(nqp::shift($iter))), - BEGIN nqp::p6bindattrinvres( # virtual Pair with 0 - nqp::create(Pair),Pair,'$!value',0) - ),Pair,'$!value') - == nqp::getattr(nqp::iterval($iter),Pair,'$!value'), - return False # missing/different: we're done - ) - ), - True # all keys identical/same value - ) - ) - ), - # true -> both empty - nqp::isfalse( - ($braw := other.RAW-HASH) && nqp::elems($braw) - ) - ) - ) - ) - } - multi method ACCEPTS(Baggy:D: Mu \other --> Bool:D) { - self.ACCEPTS(other.Bag) - } - - multi method AT-KEY(Baggy:D: \k) { # exception: ro version for Bag/Mix - nqp::if( - $!elems, - nqp::getattr( - nqp::ifnull( - nqp::atkey($!elems,k.WHICH), - BEGIN nqp::p6bindattrinvres(nqp::create(Pair),Pair,'$!value',0) - ), - Pair, - '$!value' - ), - 0 - ) - } - multi method DELETE-KEY(Baggy:D: \k) { - nqp::if( - $!elems && nqp::existskey($!elems,(my $which := k.WHICH)), - nqp::stmts( - (my $value := - nqp::getattr(nqp::atkey($!elems,$which),Pair,'$!value')), - nqp::deletekey($!elems,$which), - $value - ), - 0 - ) - } - multi method EXISTS-KEY(Baggy:D: \k) { - nqp::p6bool( - $!elems && nqp::existskey($!elems,k.WHICH) - ) - } - -#--- object creation methods - - # helper sub to create Bag from iterator, check for laziness - sub create-from-iterator(\type, \iterator --> Baggy:D) { - nqp::if( - iterator.is-lazy, - Failure.new(X::Cannot::Lazy.new(:action,:what(type.^name))), - nqp::create(type).SET-SELF( - Rakudo::QuantHash.ADD-ITERATOR-TO-BAG( - nqp::create(Rakudo::Internals::IterationSet), iterator - ) - ) - ) - } - - multi method new(Baggy:_: --> Baggy:D) { nqp::create(self) } - multi method new(Baggy:_: \value --> Baggy:D) { - nqp::if( - nqp::istype(value,Iterable) && nqp::not_i(nqp::iscont(value)), - create-from-iterator(self, value.iterator), - nqp::stmts( - nqp::bindkey( - (my $elems := nqp::create(Rakudo::Internals::IterationSet)), - value.WHICH, - Pair.new(value,1) - ), - nqp::create(self).SET-SELF($elems) - ) - ) - } - multi method new(Baggy:_: **@args) { - create-from-iterator(self, @args.iterator) - } - - method new-from-pairs(Baggy:_: *@pairs --> Baggy:D) { - nqp::if( - (my $iterator := @pairs.iterator).is-lazy, - Failure.new(X::Cannot::Lazy.new(:action,:what(self.^name))), - nqp::create(self).SET-SELF( - Rakudo::QuantHash.ADD-PAIRS-TO-BAG( - nqp::create(Rakudo::Internals::IterationSet),$iterator - ) - ) - ) - } - -#--- iterator methods - multi method iterator(Baggy:D:) { - Rakudo::Iterator.Mappy-values($!elems) - } - multi method keys(Baggy:D:) { - Seq.new(class :: does Rakudo::Iterator::Mappy { - method pull-one() { - $!iter - ?? nqp::getattr(nqp::iterval(nqp::shift($!iter)),Pair,'$!key') - !! IterationEnd - } - method push-all($target --> IterationEnd) { - nqp::while( # doesn't sink - $!iter, - $target.push( - nqp::getattr(nqp::iterval(nqp::shift($!iter)),Pair,'$!key') - ) - ) - } - }.new($!elems)) - } - multi method kv(Baggy:D:) { - Seq.new(Rakudo::Iterator.Mappy-kv-from-pairs($!elems)) - } - multi method values(Baggy:D:) { - Seq.new(class :: does Rakudo::Iterator::Mappy { - method pull-one() is raw { - nqp::if( - $!iter, - nqp::getattr(nqp::iterval(nqp::shift($!iter)),Pair,'$!value'), - IterationEnd - ) - } - method push-all($target --> IterationEnd) { - nqp::while( # doesn't sink - $!iter, - $target.push( - nqp::getattr( - nqp::iterval(nqp::shift($!iter)), - Pair, - '$!value' - ) - ) - ) - } - }.new($!elems)) - } - multi method antipairs(Baggy:D:) { - Seq.new(class :: does Rakudo::Iterator::Mappy { - method pull-one() { - nqp::if( - $!iter, - nqp::iterval(nqp::shift($!iter)).antipair, - IterationEnd - ) - } - method push-all($target --> IterationEnd) { - nqp::while( - $!iter, - $target.push(nqp::iterval(nqp::shift($!iter)).antipair), - ) - } - }.new($!elems)) - } - proto method kxxv(|) {*} - multi method kxxv(Baggy:D:) { - Seq.new(class :: does Rakudo::Iterator::Mappy { - has Mu $!key; - has int $!times; - - method pull-one() is raw { - nqp::if( - $!times, - nqp::stmts( - ($!times = nqp::sub_i($!times,1)), - $!key - ), - nqp::if( - $!iter, - nqp::stmts( - ($!key := nqp::getattr( - (my $pair := nqp::iterval(nqp::shift($!iter))), - Pair, - '$!key' - )), - ($!times = - nqp::sub_i(nqp::getattr($pair,Pair,'$!value'),1)), - $!key - ), - IterationEnd - ) - ) - } - method skip-one() { # the default skip-one, too difficult to handle - nqp::not_i(nqp::eqaddr(self.pull-one,IterationEnd)) - } - method push-all($target --> IterationEnd) { - nqp::while( - $!iter, - nqp::stmts( - ($!key := nqp::getattr( - (my $pair := nqp::iterval(nqp::shift($!iter))), - Pair, - '$!key' - )), - ($!times = - nqp::add_i(nqp::getattr($pair,Pair,'$!value'),1)), - nqp::while( # doesn't sink - ($!times = nqp::sub_i($!times,1)), - $target.push($!key) - ) - ) - ) - } - }.new($!elems)) - } - multi method invert(Baggy:D:) { - Seq.new(Rakudo::Iterator.Invert(Rakudo::Iterator.Mappy-values($!elems))) - } - -#--- introspection methods - multi method elems(Baggy:D: --> Int:D) { - nqp::istrue($!elems) && nqp::elems($!elems) - } - multi method Bool(Baggy:D: --> Bool:D) { - nqp::p6bool($!elems && nqp::elems($!elems)) - } - - method HASHIFY(\type) { - nqp::stmts( - (my $hash := Hash.^parameterize(type,Any).new), - (my $descriptor := nqp::getattr($hash,Hash,'$!descriptor')), - nqp::if( - $!elems && nqp::elems($!elems), - nqp::stmts( - (my $storage := nqp::clone($!elems)), - (my $iter := nqp::iterator($storage)), - nqp::while( - $iter, - nqp::bindkey( - $storage, - nqp::iterkey_s(nqp::shift($iter)), - nqp::p6bindattrinvres( - nqp::clone(nqp::iterval($iter)), - Pair, - '$!value', - (nqp::p6scalarfromdesc($descriptor) = - nqp::getattr(nqp::iterval($iter),Pair,'$!value')) - ) - ) - ), - nqp::bindattr($hash,Map,'$!storage',$storage) - ) - ), - $hash - ) - } - multi method hash(Baggy:D: --> Hash:D) { self.HASHIFY(Any) } - multi method Hash(Baggy:D: --> Hash:D) { self.HASHIFY(UInt) } - - method default(Baggy:D: --> 0) { } - - multi method Str(Baggy:D: --> Str:D) { - nqp::join(' ',Rakudo::QuantHash.RAW-VALUES-MAP(self, { - nqp::if( - (my $value := nqp::getattr($_,Pair,'$!value')) == 1, - nqp::getattr($_,Pair,'$!key').gist, - "{nqp::getattr($_,Pair,'$!key').gist}($value)" - ) - })) - } - multi method gist(Baggy:D: --> Str:D) { - nqp::concat( - nqp::concat( - nqp::concat(self.^name,'('), - nqp::join(', ', - Rakudo::Sorting.MERGESORT-str( - Rakudo::QuantHash.RAW-VALUES-MAP(self, { - nqp::if( - (my $value := nqp::getattr($_,Pair,'$!value')) == 1, - nqp::getattr($_,Pair,'$!key').gist, - "{nqp::getattr($_,Pair,'$!key').gist}($value)" - ) - }) - ) - ) - ), - ')', - ) - } - multi method perl(Baggy:D: --> Str:D) { - nqp::if( - $!elems && nqp::elems($!elems), - nqp::concat( - nqp::concat( - '(', - nqp::join(',', - Rakudo::QuantHash.RAW-VALUES-MAP(self, { - nqp::if( - (my $value := nqp::getattr($_,Pair,'$!value')) == 1, - nqp::getattr($_,Pair,'$!key').perl, - "{nqp::getattr($_,Pair,'$!key').perl}=>$value" - ) - }) - ) - ), - nqp::concat(').',self.^name) - ), - nqp::if( - nqp::istype(self,Bag), - 'bag()', - nqp::if( - nqp::istype(self,Mix), - 'mix()', - nqp::concat('().',self.^name) - ) - ) - ) - } - -#--- selection methods - proto method grabpairs (|) {*} - multi method grabpairs(Baggy:D:) { - nqp::if( - $!elems && nqp::elems($!elems), - nqp::stmts( - (my $iter := Rakudo::QuantHash.ROLL($!elems)), - (my $pair := nqp::iterval($iter)), - nqp::deletekey($!elems,nqp::iterkey_s($iter)), - $pair - ), - Nil - ) - } - multi method grabpairs(Baggy:D: Callable:D $calculate) { - self.grabpairs( $calculate(self.elems) ) - } - multi method grabpairs(Baggy:D: Whatever $) { - self.grabpairs(Inf) - } - multi method grabpairs(Baggy:D: $count) { - Seq.new(class :: does Rakudo::QuantHash::Pairs { - method pull-one() is raw { - nqp::if( - nqp::elems($!picked), - nqp::stmts( - (my $pair := nqp::atkey( - $!elems, - (my $key := nqp::pop_s($!picked)) - )), - nqp::deletekey($!elems,$key), - $pair - ), - IterationEnd - ) - } - }.new($!elems, $count)) - } - - proto method pickpairs(|) {*} - multi method pickpairs(Baggy:D:) { - nqp::if( - $!elems && nqp::elems($!elems), - nqp::iterval(Rakudo::QuantHash.ROLL($!elems)), - Nil - ) - } - multi method pickpairs(Baggy:D: Callable:D $calculate) { - self.pickpairs( $calculate(self.total) ) - } - multi method pickpairs(Baggy:D: Whatever $) { - self.pickpairs(Inf) - } - multi method pickpairs(Baggy:D: $count) { - Seq.new(class :: does Rakudo::QuantHash::Pairs { - method pull-one() is raw { - nqp::if( - nqp::elems($!picked), - nqp::atkey($!elems,nqp::pop_s($!picked)), - IterationEnd - ) - } - }.new($!elems, $count)) - } - - proto method grab(|) {*} - multi method grab(Baggy:D: |c) { - X::Immutable.new( method => 'grab', typename => self.^name ).throw; - } - - proto method pick(|) {*} - multi method pick(Baggy:D:) { self.roll } - multi method pick(Baggy:D: Callable:D $calculate) { - self.pick( $calculate(self.total) ) - } - multi method pick(Baggy:D: Whatever) { self.pick(Inf) } - multi method pick(Baggy:D: $count) { - Seq.new( - (my $total := self.total) < 1 - || (my $todo := $count == Inf ?? $total !! $count.Int) < 1 - ?? Rakudo::Iterator.Empty # nothing to do - !! class :: does Iterator { - has $!raw; # the IterationSet of the Baggy - has $!weights; # clone of raw, but with just the weights - has $!todo; # number of draws to do - has $!total; # total number of draws possible - - # Return the .WHICH key of a randomly picked object. Updates - # the weight of the picked object and the total number of draws - # still possible. - method BAG-PICK() { - nqp::stmts( - (my Int $rand := $!total.rand.Int), - (my Int $seen := 0), - (my $iter := nqp::iterator($!weights)), - nqp::while( - $iter && nqp::isle_I( - ($seen := nqp::add_I( - $seen, - nqp::iterval(nqp::shift($iter)), - Int - )), - $rand - ), - nqp::null - ), - nqp::bindkey( # $iter now contains picked one - $!weights, - nqp::iterkey_s($iter), - nqp::sub_I(nqp::iterval($iter),1,Int) - ), - ($!total := nqp::sub_I($!total,1,Int)), - nqp::iterkey_s($iter) - ) - } - - method SET-SELF(\raw, \todo, \total) { - nqp::stmts( - ($!weights := nqp::clone($!raw := raw)), - (my $iter := nqp::iterator($!weights)), - nqp::while( - $iter, - nqp::bindkey( - $!weights, - nqp::iterkey_s(nqp::shift($iter)), - nqp::getattr(nqp::iterval($iter),Pair,'$!value') - ) - ), - ($!todo := nqp::if(todo > total,total,todo)), - ($!total := total), - self - ) - } - method new(\raw, \todo, \total) { - nqp::create(self).SET-SELF(raw, todo, total) - } - - method pull-one() is raw { - nqp::if( - $!todo, - nqp::stmts( - ($!todo := nqp::sub_I($!todo,1,Int)), - nqp::getattr(nqp::atkey($!raw,self.BAG-PICK),Pair,'$!key') - ), - IterationEnd - ) - } - method skip-one() { - nqp::if( - $!todo, - nqp::stmts( - ($!todo := nqp::sub_I($!todo,1,Int)), - self.BAG-PICK - ) - ) - } - method push-all($target --> IterationEnd) { - nqp::stmts( - (my $todo = $!todo), - nqp::while( - $todo, - nqp::stmts( - --$todo, - $target.push(nqp::getattr( - nqp::atkey($!raw,self.BAG-PICK), - Pair, - '$!key' - )) - ) - ), - ($!todo := nqp::decont($todo)) - ) - } - method count-only() { $!todo - 1 } - method bool-only(--> True) { } - method sink-all() { $!todo := 0 } - - }.new($!elems, $todo, nqp::ifnull($total,self.total)) - ) - } - - proto method roll(|) {*} - multi method roll(Baggy:D:) { - nqp::if( - $!elems && (my $total := self.total), - nqp::getattr( - nqp::iterval(Rakudo::QuantHash.BAG-ROLL($!elems,$total)), - Pair, - '$!key' - ), - Nil - ) - } - multi method roll(Baggy:D: Whatever) { - Seq.new(nqp::if( - $!elems && (my $total := self.total), - Rakudo::Iterator.Callable( { - nqp::getattr( - nqp::iterval(Rakudo::QuantHash.BAG-ROLL($!elems, $total)), - Pair, - '$!key' - ) - }, True ), - Rakudo::Iterator.Empty - )) - } - multi method roll(Baggy:D: Callable:D $calculate) { - nqp::if( - (my $total := self.total), - self.roll($calculate($total)), - Seq.new(Rakudo::Iterator.Empty) - ) - } - multi method roll(Baggy:D: $count) { - nqp::if( - $count == Inf, - self.roll(*), # let Whatever handle it - Seq.new(nqp::if( # something else as count - (my $todo = $count.Int) < 1, # also handles NaN - Rakudo::Iterator.Empty, # nothing to do - nqp::if( - $!elems && (my $total := self.total) && ++$todo, - Rakudo::Iterator.Callable( { # need to do a number of times - nqp::if( - --$todo, - nqp::getattr( - nqp::iterval(Rakudo::QuantHash.BAG-ROLL($!elems, $total)), - Pair, - '$!key' - ), - IterationEnd - ) - }), - Rakudo::Iterator.Empty # nothing to roll for - ) - )) - ) - } - -#--- classification method - proto method classify-list(|) {*} - multi method classify-list( &test, \list) { - fail X::Cannot::Lazy.new(:action) if list.is-lazy; - my \iter = (nqp::istype(list, Iterable) ?? list !! list.list).iterator; - - while (my $value := iter.pull-one) !=:= IterationEnd { - my $tested := test($value); - if nqp::istype($tested, Iterable) { # multi-level classify - X::Invalid::ComputedValue.new( - :name, - :method, - :value, - :reason(self.^name ~ ' cannot be nested and so does not ' - ~ 'support multi-level classification'), - ).throw; - } - else { - ++self{$tested}; - } - } - self; - } - multi method classify-list( %test, |c ) { - self.classify-list( { %test{$^a} }, |c ); - } - multi method classify-list( @test, |c ) { - self.classify-list( { @test[$^a] }, |c ); - } - multi method classify-list(&test, **@list, |c) { - self.classify-list(&test, @list, |c); - } - - proto method categorize-list(|) {*} - multi method categorize-list( &test, \list ) { - fail X::Cannot::Lazy.new(:action) if list.is-lazy; - my \iter = (nqp::istype(list, Iterable) ?? list !! list.list).iterator; - my $value := iter.pull-one; - unless $value =:= IterationEnd { - my $tested := test($value); - - # multi-level categorize - if nqp::istype($tested[0],Iterable) { - X::Invalid::ComputedValue.new( - :name, - :method, - :value, - :reason(self.^name ~ ' cannot be nested and so does not ' - ~ 'support multi-level categorization'), - ).throw; - } - # simple categorize - else { - loop { - ++self{$_} for @$tested; - last if ($value := iter.pull-one) =:= IterationEnd; - nqp::istype(($tested := test($value))[0], Iterable) - and X::Invalid::ComputedValue.new( - :name, - :method, - :value('an item with different number of elements ' - ~ 'in it than previous items'), - :reason('all values need to have the same number ' - ~ 'of elements. Mixed-level classification is ' - ~ 'not supported.'), - ).throw; - }; - } - } - self; - } - multi method categorize-list( %test, |c ) { - self.categorize-list( { %test{$^a} }, |c ); - } - multi method categorize-list( @test, |c ) { - self.categorize-list( { @test[$^a] }, |c ); - } - multi method categorize-list( &test, **@list, |c ) { - self.categorize-list( &test, @list, |c ); - } - -#--- coercion methods - sub SETIFY(\raw, \type) { - nqp::if( - raw && nqp::elems(raw), - nqp::stmts( - (my $elems := nqp::clone(raw)), - (my $iter := nqp::iterator($elems)), - nqp::while( - $iter, - nqp::bindkey( - $elems, - nqp::iterkey_s(nqp::shift($iter)), - nqp::getattr(nqp::iterval($iter),Pair,'$!key'), - ) - ), - nqp::create(type).SET-SELF($elems) - ), - nqp::if( - nqp::eqaddr(type,Set), - set(), - nqp::create(type) - ) - ) - } - multi method Set(Baggy:D:) { SETIFY($!elems,Set) } - multi method SetHash(Baggy:D:) { SETIFY($!elems,SetHash) } - - sub MIXIFY(\raw, \type) { - nqp::if( - raw && nqp::elems(raw), - nqp::create(type).SET-SELF(Rakudo::QuantHash.BAGGY-CLONE(raw)), - nqp::if( - nqp::istype(type,Mix), - mix(), - nqp::create(MixHash) - ) - ) - } - - multi method Mix(Baggy:D:) { MIXIFY($!elems, Mix) } - multi method MixHash(Baggy:D:) { MIXIFY($!elems, MixHash) } - - method RAW-HASH() is raw { $!elems } -} - -multi sub infix:(Baggy:D \a, Baggy:D \b --> Bool:D) { - nqp::p6bool( - nqp::eqaddr(a,b) || (nqp::eqaddr(a.WHAT,b.WHAT) && a.ACCEPTS(b)) - ) -} -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Baggy.pm6 rakudo-2018.03/src/core/Baggy.pm6 --- rakudo-2018.02.1/src/core/Baggy.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Baggy.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,727 @@ +my role Baggy does QuantHash { + +# A Bag/BagHash/Mix/MixHash consists of a single hash with Pairs. +# The keys of the hash, are the .WHICH strings of the original object key. +# The values are Pairs containing the original object key and value. + + has Rakudo::Internals::IterationSet $!elems; # key.WHICH => (key,value) + +# The Baggy role takes care of all mutable and immutable aspects that are +# shared between Bag,BagHash,Mix,MixHash. Any specific behaviour for +# mutable and immutable aspects of Mix/MixHash need to live in Mixy. +# Immutables aspects of Bag/Mix, need to live to Bag/Mix respectively. + +#--- interface methods + multi method ACCEPTS(Baggy:U: \other --> Bool:D) { + other.^does(self) + } + multi method ACCEPTS(Baggy:D: Baggy:D \other --> Bool:D) { + nqp::p6bool( + nqp::unless( + nqp::eqaddr(self,other), + nqp::if( # not same object + (my $araw := $!elems), + nqp::if( # something on left + (my $braw := other.RAW-HASH), + nqp::if( # something on both sides + nqp::iseq_i(nqp::elems($araw),nqp::elems($braw)), + nqp::stmts( # same size + (my $iter := nqp::iterator($araw)), + nqp::while( + $iter, + nqp::unless( + nqp::getattr( + nqp::ifnull( + nqp::atkey($braw,nqp::iterkey_s(nqp::shift($iter))), + BEGIN nqp::p6bindattrinvres( # virtual Pair with 0 + nqp::create(Pair),Pair,'$!value',0) + ),Pair,'$!value') + == nqp::getattr(nqp::iterval($iter),Pair,'$!value'), + return False # missing/different: we're done + ) + ), + True # all keys identical/same value + ) + ) + ), + # true -> both empty + nqp::isfalse( + ($braw := other.RAW-HASH) && nqp::elems($braw) + ) + ) + ) + ) + } + multi method ACCEPTS(Baggy:D: Mu \other --> Bool:D) { + self.ACCEPTS(other.Bag) + } + + multi method AT-KEY(Baggy:D: \k) { # exception: ro version for Bag/Mix + nqp::if( + $!elems, + nqp::getattr( + nqp::ifnull( + nqp::atkey($!elems,k.WHICH), + BEGIN nqp::p6bindattrinvres(nqp::create(Pair),Pair,'$!value',0) + ), + Pair, + '$!value' + ), + 0 + ) + } + multi method DELETE-KEY(Baggy:D: \k) { + nqp::if( + $!elems && nqp::existskey($!elems,(my $which := k.WHICH)), + nqp::stmts( + (my $value := + nqp::getattr(nqp::atkey($!elems,$which),Pair,'$!value')), + nqp::deletekey($!elems,$which), + $value + ), + 0 + ) + } + multi method EXISTS-KEY(Baggy:D: \k) { + nqp::p6bool( + $!elems && nqp::existskey($!elems,k.WHICH) + ) + } + +#--- object creation methods + + # helper sub to create Bag from iterator, check for laziness + sub create-from-iterator(\type, \iterator --> Baggy:D) { + nqp::if( + iterator.is-lazy, + Failure.new(X::Cannot::Lazy.new(:action,:what(type.^name))), + nqp::create(type).SET-SELF( + Rakudo::QuantHash.ADD-ITERATOR-TO-BAG( + nqp::create(Rakudo::Internals::IterationSet), iterator + ) + ) + ) + } + + multi method new(Baggy:_: --> Baggy:D) { nqp::create(self) } + multi method new(Baggy:_: \value --> Baggy:D) { + nqp::if( + nqp::istype(value,Iterable) && nqp::not_i(nqp::iscont(value)), + create-from-iterator(self, value.iterator), + nqp::stmts( + nqp::bindkey( + (my $elems := nqp::create(Rakudo::Internals::IterationSet)), + value.WHICH, + Pair.new(value,1) + ), + nqp::create(self).SET-SELF($elems) + ) + ) + } + multi method new(Baggy:_: **@args) { + create-from-iterator(self, @args.iterator) + } + + method new-from-pairs(Baggy:_: *@pairs --> Baggy:D) { + nqp::if( + (my $iterator := @pairs.iterator).is-lazy, + Failure.new(X::Cannot::Lazy.new(:action,:what(self.^name))), + nqp::create(self).SET-SELF( + Rakudo::QuantHash.ADD-PAIRS-TO-BAG( + nqp::create(Rakudo::Internals::IterationSet),$iterator + ) + ) + ) + } + +#--- iterator methods + multi method iterator(Baggy:D:) { + Rakudo::Iterator.Mappy-values($!elems) + } + multi method keys(Baggy:D:) { + Seq.new(class :: does Rakudo::Iterator::Mappy { + method pull-one() { + $!iter + ?? nqp::getattr(nqp::iterval(nqp::shift($!iter)),Pair,'$!key') + !! IterationEnd + } + method push-all($target --> IterationEnd) { + nqp::while( # doesn't sink + $!iter, + $target.push( + nqp::getattr(nqp::iterval(nqp::shift($!iter)),Pair,'$!key') + ) + ) + } + }.new($!elems)) + } + multi method kv(Baggy:D:) { + Seq.new(Rakudo::Iterator.Mappy-kv-from-pairs($!elems)) + } + multi method values(Baggy:D:) { + Seq.new(class :: does Rakudo::Iterator::Mappy { + method pull-one() is raw { + nqp::if( + $!iter, + nqp::getattr(nqp::iterval(nqp::shift($!iter)),Pair,'$!value'), + IterationEnd + ) + } + method push-all($target --> IterationEnd) { + nqp::while( # doesn't sink + $!iter, + $target.push( + nqp::getattr( + nqp::iterval(nqp::shift($!iter)), + Pair, + '$!value' + ) + ) + ) + } + }.new($!elems)) + } + multi method antipairs(Baggy:D:) { + Seq.new(class :: does Rakudo::Iterator::Mappy { + method pull-one() { + nqp::if( + $!iter, + nqp::iterval(nqp::shift($!iter)).antipair, + IterationEnd + ) + } + method push-all($target --> IterationEnd) { + nqp::while( + $!iter, + $target.push(nqp::iterval(nqp::shift($!iter)).antipair), + ) + } + }.new($!elems)) + } + proto method kxxv(|) {*} + multi method kxxv(Baggy:D:) { + Seq.new(class :: does Rakudo::Iterator::Mappy { + has Mu $!key; + has int $!times; + + method pull-one() is raw { + nqp::if( + $!times, + nqp::stmts( + ($!times = nqp::sub_i($!times,1)), + $!key + ), + nqp::if( + $!iter, + nqp::stmts( + ($!key := nqp::getattr( + (my $pair := nqp::iterval(nqp::shift($!iter))), + Pair, + '$!key' + )), + ($!times = + nqp::sub_i(nqp::getattr($pair,Pair,'$!value'),1)), + $!key + ), + IterationEnd + ) + ) + } + method skip-one() { # the default skip-one, too difficult to handle + nqp::not_i(nqp::eqaddr(self.pull-one,IterationEnd)) + } + method push-all($target --> IterationEnd) { + nqp::while( + $!iter, + nqp::stmts( + ($!key := nqp::getattr( + (my $pair := nqp::iterval(nqp::shift($!iter))), + Pair, + '$!key' + )), + ($!times = + nqp::add_i(nqp::getattr($pair,Pair,'$!value'),1)), + nqp::while( # doesn't sink + ($!times = nqp::sub_i($!times,1)), + $target.push($!key) + ) + ) + ) + } + }.new($!elems)) + } + multi method invert(Baggy:D:) { + Seq.new(Rakudo::Iterator.Invert(Rakudo::Iterator.Mappy-values($!elems))) + } + +#--- introspection methods + multi method elems(Baggy:D: --> Int:D) { + nqp::istrue($!elems) && nqp::elems($!elems) + } + multi method Bool(Baggy:D: --> Bool:D) { + nqp::p6bool($!elems && nqp::elems($!elems)) + } + + method HASHIFY(\type) { + nqp::stmts( + (my $hash := Hash.^parameterize(type,Any).new), + (my $descriptor := nqp::getattr($hash,Hash,'$!descriptor')), + nqp::if( + $!elems && nqp::elems($!elems), + nqp::stmts( + (my $storage := nqp::clone($!elems)), + (my $iter := nqp::iterator($storage)), + nqp::while( + $iter, + nqp::bindkey( + $storage, + nqp::iterkey_s(nqp::shift($iter)), + nqp::p6bindattrinvres( + nqp::clone(nqp::iterval($iter)), + Pair, + '$!value', + (nqp::p6scalarfromdesc($descriptor) = + nqp::getattr(nqp::iterval($iter),Pair,'$!value')) + ) + ) + ), + nqp::bindattr($hash,Map,'$!storage',$storage) + ) + ), + $hash + ) + } + multi method hash(Baggy:D: --> Hash:D) { self.HASHIFY(Any) } + multi method Hash(Baggy:D: --> Hash:D) { self.HASHIFY(UInt) } + + method default(Baggy:D: --> 0) { } + + multi method Str(Baggy:D: --> Str:D) { + nqp::join(' ',Rakudo::QuantHash.RAW-VALUES-MAP(self, { + nqp::if( + (my $value := nqp::getattr($_,Pair,'$!value')) == 1, + nqp::getattr($_,Pair,'$!key').gist, + "{nqp::getattr($_,Pair,'$!key').gist}($value)" + ) + })) + } + multi method gist(Baggy:D: --> Str:D) { + nqp::concat( + nqp::concat( + nqp::concat(self.^name,'('), + nqp::join(', ', + Rakudo::Sorting.MERGESORT-str( + Rakudo::QuantHash.RAW-VALUES-MAP(self, { + nqp::if( + (my $value := nqp::getattr($_,Pair,'$!value')) == 1, + nqp::getattr($_,Pair,'$!key').gist, + "{nqp::getattr($_,Pair,'$!key').gist}($value)" + ) + }) + ) + ) + ), + ')', + ) + } + multi method perl(Baggy:D: --> Str:D) { + nqp::if( + $!elems && nqp::elems($!elems), + nqp::concat( + nqp::concat( + '(', + nqp::join(',', + Rakudo::QuantHash.RAW-VALUES-MAP(self, { + nqp::if( + (my $value := nqp::getattr($_,Pair,'$!value')) == 1, + nqp::getattr($_,Pair,'$!key').perl, + "{nqp::getattr($_,Pair,'$!key').perl}=>$value" + ) + }) + ) + ), + nqp::concat(').',self.^name) + ), + nqp::if( + nqp::istype(self,Bag), + 'bag()', + nqp::if( + nqp::istype(self,Mix), + 'mix()', + nqp::concat('().',self.^name) + ) + ) + ) + } + +#--- selection methods + proto method grabpairs (|) {*} + multi method grabpairs(Baggy:D:) { + nqp::if( + $!elems && nqp::elems($!elems), + nqp::stmts( + (my $iter := Rakudo::QuantHash.ROLL($!elems)), + (my $pair := nqp::iterval($iter)), + nqp::deletekey($!elems,nqp::iterkey_s($iter)), + $pair + ), + Nil + ) + } + multi method grabpairs(Baggy:D: Callable:D $calculate) { + self.grabpairs( $calculate(self.elems) ) + } + multi method grabpairs(Baggy:D: Whatever $) { + self.grabpairs(Inf) + } + multi method grabpairs(Baggy:D: $count) { + Seq.new(class :: does Rakudo::QuantHash::Pairs { + method pull-one() is raw { + nqp::if( + nqp::elems($!picked), + nqp::stmts( + (my $pair := nqp::atkey( + $!elems, + (my $key := nqp::pop_s($!picked)) + )), + nqp::deletekey($!elems,$key), + $pair + ), + IterationEnd + ) + } + }.new($!elems, $count)) + } + + proto method pickpairs(|) {*} + multi method pickpairs(Baggy:D:) { + nqp::if( + $!elems && nqp::elems($!elems), + nqp::iterval(Rakudo::QuantHash.ROLL($!elems)), + Nil + ) + } + multi method pickpairs(Baggy:D: Callable:D $calculate) { + self.pickpairs( $calculate(self.total) ) + } + multi method pickpairs(Baggy:D: Whatever $) { + self.pickpairs(Inf) + } + multi method pickpairs(Baggy:D: $count) { + Seq.new(class :: does Rakudo::QuantHash::Pairs { + method pull-one() is raw { + nqp::if( + nqp::elems($!picked), + nqp::atkey($!elems,nqp::pop_s($!picked)), + IterationEnd + ) + } + }.new($!elems, $count)) + } + + proto method grab(|) {*} + multi method grab(Baggy:D: |c) { + X::Immutable.new( method => 'grab', typename => self.^name ).throw; + } + + proto method pick(|) {*} + multi method pick(Baggy:D:) { self.roll } + multi method pick(Baggy:D: Callable:D $calculate) { + self.pick( $calculate(self.total) ) + } + multi method pick(Baggy:D: Whatever) { self.pick(Inf) } + multi method pick(Baggy:D: $count) { + Seq.new( + (my $total := self.total) < 1 + || (my $todo := $count == Inf ?? $total !! $count.Int) < 1 + ?? Rakudo::Iterator.Empty # nothing to do + !! class :: does Iterator { + has $!raw; # the IterationSet of the Baggy + has $!weights; # clone of raw, but with just the weights + has $!todo; # number of draws to do + has $!total; # total number of draws possible + + # Return the .WHICH key of a randomly picked object. Updates + # the weight of the picked object and the total number of draws + # still possible. + method BAG-PICK() { + nqp::stmts( + (my Int $rand := $!total.rand.Int), + (my Int $seen := 0), + (my $iter := nqp::iterator($!weights)), + nqp::while( + $iter && nqp::isle_I( + ($seen := nqp::add_I( + $seen, + nqp::iterval(nqp::shift($iter)), + Int + )), + $rand + ), + nqp::null + ), + nqp::bindkey( # $iter now contains picked one + $!weights, + nqp::iterkey_s($iter), + nqp::sub_I(nqp::iterval($iter),1,Int) + ), + ($!total := nqp::sub_I($!total,1,Int)), + nqp::iterkey_s($iter) + ) + } + + method SET-SELF(\raw, \todo, \total) { + nqp::stmts( + ($!weights := nqp::clone($!raw := raw)), + (my $iter := nqp::iterator($!weights)), + nqp::while( + $iter, + nqp::bindkey( + $!weights, + nqp::iterkey_s(nqp::shift($iter)), + nqp::getattr(nqp::iterval($iter),Pair,'$!value') + ) + ), + ($!todo := nqp::if(todo > total,total,todo)), + ($!total := total), + self + ) + } + method new(\raw, \todo, \total) { + nqp::create(self).SET-SELF(raw, todo, total) + } + + method pull-one() is raw { + nqp::if( + $!todo, + nqp::stmts( + ($!todo := nqp::sub_I($!todo,1,Int)), + nqp::getattr(nqp::atkey($!raw,self.BAG-PICK),Pair,'$!key') + ), + IterationEnd + ) + } + method skip-one() { + nqp::if( + $!todo, + nqp::stmts( + ($!todo := nqp::sub_I($!todo,1,Int)), + self.BAG-PICK + ) + ) + } + method push-all($target --> IterationEnd) { + nqp::stmts( + (my $todo = $!todo), + nqp::while( + $todo, + nqp::stmts( + --$todo, + $target.push(nqp::getattr( + nqp::atkey($!raw,self.BAG-PICK), + Pair, + '$!key' + )) + ) + ), + ($!todo := nqp::decont($todo)) + ) + } + method count-only() { $!todo - 1 } + method bool-only(--> True) { } + method sink-all() { $!todo := 0 } + + }.new($!elems, $todo, nqp::ifnull($total,self.total)) + ) + } + + proto method roll(|) {*} + multi method roll(Baggy:D:) { + nqp::if( + $!elems && (my $total := self.total), + nqp::getattr( + nqp::iterval(Rakudo::QuantHash.BAG-ROLL($!elems,$total)), + Pair, + '$!key' + ), + Nil + ) + } + multi method roll(Baggy:D: Whatever) { + Seq.new(nqp::if( + $!elems && (my $total := self.total), + Rakudo::Iterator.Callable( { + nqp::getattr( + nqp::iterval(Rakudo::QuantHash.BAG-ROLL($!elems, $total)), + Pair, + '$!key' + ) + }, True ), + Rakudo::Iterator.Empty + )) + } + multi method roll(Baggy:D: Callable:D $calculate) { + nqp::if( + (my $total := self.total), + self.roll($calculate($total)), + Seq.new(Rakudo::Iterator.Empty) + ) + } + multi method roll(Baggy:D: $count) { + nqp::if( + $count == Inf, + self.roll(*), # let Whatever handle it + Seq.new(nqp::if( # something else as count + (my $todo = $count.Int) < 1, # also handles NaN + Rakudo::Iterator.Empty, # nothing to do + nqp::if( + $!elems && (my $total := self.total) && ++$todo, + Rakudo::Iterator.Callable( { # need to do a number of times + nqp::if( + --$todo, + nqp::getattr( + nqp::iterval(Rakudo::QuantHash.BAG-ROLL($!elems, $total)), + Pair, + '$!key' + ), + IterationEnd + ) + }), + Rakudo::Iterator.Empty # nothing to roll for + ) + )) + ) + } + +#--- classification method + proto method classify-list(|) {*} + multi method classify-list( &test, \list) { + fail X::Cannot::Lazy.new(:action) if list.is-lazy; + my \iter = (nqp::istype(list, Iterable) ?? list !! list.list).iterator; + + while (my $value := iter.pull-one) !=:= IterationEnd { + my $tested := test($value); + if nqp::istype($tested, Iterable) { # multi-level classify + X::Invalid::ComputedValue.new( + :name, + :method, + :value, + :reason(self.^name ~ ' cannot be nested and so does not ' + ~ 'support multi-level classification'), + ).throw; + } + else { + ++self{$tested}; + } + } + self; + } + multi method classify-list( %test, |c ) { + self.classify-list( { %test{$^a} }, |c ); + } + multi method classify-list( @test, |c ) { + self.classify-list( { @test[$^a] }, |c ); + } + multi method classify-list(&test, **@list, |c) { + self.classify-list(&test, @list, |c); + } + + proto method categorize-list(|) {*} + multi method categorize-list( &test, \list ) { + fail X::Cannot::Lazy.new(:action) if list.is-lazy; + my \iter = (nqp::istype(list, Iterable) ?? list !! list.list).iterator; + my $value := iter.pull-one; + unless $value =:= IterationEnd { + my $tested := test($value); + + # multi-level categorize + if nqp::istype($tested[0],Iterable) { + X::Invalid::ComputedValue.new( + :name, + :method, + :value, + :reason(self.^name ~ ' cannot be nested and so does not ' + ~ 'support multi-level categorization'), + ).throw; + } + # simple categorize + else { + loop { + ++self{$_} for @$tested; + last if ($value := iter.pull-one) =:= IterationEnd; + nqp::istype(($tested := test($value))[0], Iterable) + and X::Invalid::ComputedValue.new( + :name, + :method, + :value('an item with different number of elements ' + ~ 'in it than previous items'), + :reason('all values need to have the same number ' + ~ 'of elements. Mixed-level classification is ' + ~ 'not supported.'), + ).throw; + }; + } + } + self; + } + multi method categorize-list( %test, |c ) { + self.categorize-list( { %test{$^a} }, |c ); + } + multi method categorize-list( @test, |c ) { + self.categorize-list( { @test[$^a] }, |c ); + } + multi method categorize-list( &test, **@list, |c ) { + self.categorize-list( &test, @list, |c ); + } + +#--- coercion methods + sub SETIFY(\raw, \type) { + nqp::if( + raw && nqp::elems(raw), + nqp::stmts( + (my $elems := nqp::clone(raw)), + (my $iter := nqp::iterator($elems)), + nqp::while( + $iter, + nqp::bindkey( + $elems, + nqp::iterkey_s(nqp::shift($iter)), + nqp::getattr(nqp::iterval($iter),Pair,'$!key'), + ) + ), + nqp::create(type).SET-SELF($elems) + ), + nqp::if( + nqp::eqaddr(type,Set), + set(), + nqp::create(type) + ) + ) + } + multi method Set(Baggy:D:) { SETIFY($!elems,Set) } + multi method SetHash(Baggy:D:) { SETIFY($!elems,SetHash) } + + sub MIXIFY(\raw, \type) { + nqp::if( + raw && nqp::elems(raw), + nqp::create(type).SET-SELF(Rakudo::QuantHash.BAGGY-CLONE(raw)), + nqp::if( + nqp::istype(type,Mix), + mix(), + nqp::create(MixHash) + ) + ) + } + + multi method Mix(Baggy:D:) { MIXIFY($!elems, Mix) } + multi method MixHash(Baggy:D:) { MIXIFY($!elems, MixHash) } + + method RAW-HASH() is raw { $!elems } +} + +multi sub infix:(Baggy:D \a, Baggy:D \b --> Bool:D) { + nqp::p6bool( + nqp::eqaddr(a,b) || (nqp::eqaddr(a.WHAT,b.WHAT) && a.ACCEPTS(b)) + ) +} +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/BagHash.pm rakudo-2018.03/src/core/BagHash.pm --- rakudo-2018.02.1/src/core/BagHash.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/BagHash.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,270 +0,0 @@ -my class BagHash does Baggy { - -#--- interface methods - method STORE(*@pairs --> BagHash:D) { - nqp::if( - (my $iterator := @pairs.iterator).is-lazy, - Failure.new(X::Cannot::Lazy.new(:action,:what(self.^name))), - self.SET-SELF( - Rakudo::QuantHash.ADD-PAIRS-TO-BAG( - nqp::create(Rakudo::Internals::IterationSet), $iterator - ) - ) - ) - } - multi method AT-KEY(BagHash:D: \k) is raw { - Proxy.new( - FETCH => { - nqp::if( - $!elems && nqp::existskey($!elems,(my $which := k.WHICH)), - nqp::getattr(nqp::atkey($!elems,$which),Pair,'$!value'), - 0 - ) - }, - STORE => -> $, Int() $value { - nqp::if( - nqp::istype($value,Failure), # RT 128927 - $value.throw, - nqp::if( - $!elems, - nqp::if( # allocated hash - nqp::existskey($!elems,(my $which := k.WHICH)), - nqp::if( # existing element - nqp::isgt_i($value,0), - nqp::bindattr( - nqp::atkey($!elems,$which), - Pair, - '$!value', - nqp::decont($value) - ), - nqp::stmts( - nqp::deletekey($!elems,$which), - 0 - ) - ), - nqp::if( - nqp::isgt_i($value,0), # new - nqp::bindkey( - $!elems, - $which, - Pair.new(k,nqp::decont($value)) - ) - ) - ), - nqp::if( # no hash allocated yet - nqp::isgt_i($value,0), - nqp::bindkey( - nqp::bindattr(self,::?CLASS,'$!elems', - nqp::create(Rakudo::Internals::IterationSet)), - k.WHICH, - Pair.new(k,nqp::decont($value)) - ) - ) - ) - ) - } - ) - } - -#--- introspection methods - method total() { Rakudo::QuantHash.BAG-TOTAL($!elems) } - -#--- coercion methods - multi method Bag(BagHash:D: :$view) { - nqp::if( - $!elems && nqp::elems($!elems), - nqp::create(Bag).SET-SELF( # not empty - nqp::if( - $view, - $!elems, # BagHash won't change - Rakudo::QuantHash.BAGGY-CLONE($!elems) # need deep copy - ) - ), - bag() # empty, bag() will do - ) - } - multi method BagHash(BagHash:D:) { self } - multi method Mix(BagHash:D:) { - nqp::if( - $!elems && nqp::elems($!elems), - nqp::create(Mix).SET-SELF(Rakudo::QuantHash.BAGGY-CLONE($!elems)), - mix() - ) - } - multi method MixHash(BagHash:D:) { - nqp::if( - $!elems && nqp::elems($!elems), - nqp::create(MixHash).SET-SELF(Rakudo::QuantHash.BAGGY-CLONE($!elems)), - nqp::create(MixHash) - ) - } - method clone() { - nqp::if( - $!elems && nqp::elems($!elems), - nqp::create(BagHash).SET-SELF(Rakudo::QuantHash.BAGGY-CLONE($!elems)), - nqp::create(BagHash) - ) - } - -#--- iterator methods - - sub proxy(Mu \iter,Mu \storage) is raw { - # We are only sure that the key exists when the Proxy - # is made, but we cannot be sure of its existence when - # either the FETCH or STORE block is executed. So we - # still need to check for existence, and handle the case - # where we need to (re-create) the key and value. The - # logic is therefore basically the same as in AT-KEY, - # except for tests for allocated storage and .WHICH - # processing. - nqp::stmts( - (my $which := nqp::iterkey_s(iter)), - # save object for potential recreation - (my $object := nqp::getattr(nqp::iterval(iter),Pair,'$!key')), - - Proxy.new( - FETCH => { - nqp::if( - nqp::existskey(storage,$which), - nqp::getattr(nqp::atkey(storage,$which),Pair,'$!value'), - 0 - ) - }, - STORE => -> $, Int() $value { - nqp::if( - nqp::istype($value,Failure), # RT 128927 - $value.throw, - nqp::if( - nqp::existskey(storage,$which), - nqp::if( # existing element - nqp::isgt_i($value,0), - nqp::bindattr( # value ok - nqp::atkey(storage,$which), - Pair, - '$!value', - nqp::decont($value) - ), - nqp::stmts( # goodbye! - nqp::deletekey(storage,$which), - 0 - ) - ), - nqp::if( # where did it go? - nqp::isgt_i($value,0), - nqp::bindkey( - storage, - $which, - Pair.new($object,nqp::decont($value)) - ) - ) - ) - ) - } - ) - ) - } - - multi method iterator(BagHash:D:) { # also .pairs - class :: does Rakudo::Iterator::Mappy { - method pull-one() is raw { - nqp::if( - $!iter, - nqp::p6bindattrinvres( - nqp::clone(nqp::iterval(nqp::shift($!iter))), - Pair, - '$!value', - proxy($!iter,$!hash) - ), - IterationEnd - ) - } - method push-all($target --> IterationEnd) { - nqp::while( # doesn't sink - $!iter, - $target.push(nqp::iterval(nqp::shift($!iter))) - ) - } - }.new($!elems) - } - - multi method values(BagHash:D:) { - Seq.new(class :: does Rakudo::Iterator::Mappy { - method pull-one() is raw { - nqp::if( - $!iter, - proxy(nqp::shift($!iter),$!hash), - IterationEnd - ) - } - - # same as Baggy.values - method push-all($target --> IterationEnd) { - nqp::while( # doesn't sink - $!iter, - $target.push(nqp::getattr( - nqp::iterval(nqp::shift($!iter)),Pair,'$!value')) - ) - } - }.new($!elems)) - } - - multi method kv(BagHash:D:) { - Seq.new(class :: does Rakudo::Iterator::Mappy-kv-from-pairs { - method pull-one() is raw { - nqp::if( - $!on, - nqp::stmts( - ($!on = 0), - proxy($!iter,$!hash) - ), - nqp::if( - $!iter, - nqp::stmts( - ($!on = 1), - nqp::getattr( - nqp::iterval(nqp::shift($!iter)),Pair,'$!key') - ), - IterationEnd - ) - ) - } - }.new($!elems)) - } - -#---- selection methods - multi method grab(BagHash:D:) { - nqp::if( - $!elems && nqp::elems($!elems), - Rakudo::QuantHash.BAG-GRAB($!elems,self.total), - Nil - ) - } - multi method grab(BagHash:D: Callable:D $calculate) { - self.grab( $calculate(self.total) ) - } - multi method grab(BagHash:D: Whatever) { self.grab(Inf) } - multi method grab(BagHash:D: $count) { - Seq.new(nqp::if( - (my $todo = Rakudo::QuantHash.TODO($count)) - && $!elems - && nqp::elems($!elems), - nqp::stmts( - (my Int $total = self.total), - nqp::if($todo > $total,$todo = $total), - Rakudo::Iterator.Callable( { - nqp::if( - $todo, - nqp::stmts( - --$todo, - Rakudo::QuantHash.BAG-GRAB($!elems,$total--) - ), - IterationEnd - ) - } ) - ), - Rakudo::Iterator.Empty - )) - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/BagHash.pm6 rakudo-2018.03/src/core/BagHash.pm6 --- rakudo-2018.02.1/src/core/BagHash.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/BagHash.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,270 @@ +my class BagHash does Baggy { + +#--- interface methods + method STORE(*@pairs --> BagHash:D) { + nqp::if( + (my $iterator := @pairs.iterator).is-lazy, + Failure.new(X::Cannot::Lazy.new(:action,:what(self.^name))), + self.SET-SELF( + Rakudo::QuantHash.ADD-PAIRS-TO-BAG( + nqp::create(Rakudo::Internals::IterationSet), $iterator + ) + ) + ) + } + multi method AT-KEY(BagHash:D: \k) is raw { + Proxy.new( + FETCH => { + nqp::if( + $!elems && nqp::existskey($!elems,(my $which := k.WHICH)), + nqp::getattr(nqp::atkey($!elems,$which),Pair,'$!value'), + 0 + ) + }, + STORE => -> $, Int() $value { + nqp::if( + nqp::istype($value,Failure), # RT 128927 + $value.throw, + nqp::if( + $!elems, + nqp::if( # allocated hash + nqp::existskey($!elems,(my $which := k.WHICH)), + nqp::if( # existing element + nqp::isgt_i($value,0), + nqp::bindattr( + nqp::atkey($!elems,$which), + Pair, + '$!value', + nqp::decont($value) + ), + nqp::stmts( + nqp::deletekey($!elems,$which), + 0 + ) + ), + nqp::if( + nqp::isgt_i($value,0), # new + nqp::bindkey( + $!elems, + $which, + Pair.new(k,nqp::decont($value)) + ) + ) + ), + nqp::if( # no hash allocated yet + nqp::isgt_i($value,0), + nqp::bindkey( + nqp::bindattr(self,::?CLASS,'$!elems', + nqp::create(Rakudo::Internals::IterationSet)), + k.WHICH, + Pair.new(k,nqp::decont($value)) + ) + ) + ) + ) + } + ) + } + +#--- introspection methods + method total() { Rakudo::QuantHash.BAG-TOTAL($!elems) } + +#--- coercion methods + multi method Bag(BagHash:D: :$view) { + nqp::if( + $!elems && nqp::elems($!elems), + nqp::create(Bag).SET-SELF( # not empty + nqp::if( + $view, + $!elems, # BagHash won't change + Rakudo::QuantHash.BAGGY-CLONE($!elems) # need deep copy + ) + ), + bag() # empty, bag() will do + ) + } + multi method BagHash(BagHash:D:) { self } + multi method Mix(BagHash:D:) { + nqp::if( + $!elems && nqp::elems($!elems), + nqp::create(Mix).SET-SELF(Rakudo::QuantHash.BAGGY-CLONE($!elems)), + mix() + ) + } + multi method MixHash(BagHash:D:) { + nqp::if( + $!elems && nqp::elems($!elems), + nqp::create(MixHash).SET-SELF(Rakudo::QuantHash.BAGGY-CLONE($!elems)), + nqp::create(MixHash) + ) + } + method clone() { + nqp::if( + $!elems && nqp::elems($!elems), + nqp::create(BagHash).SET-SELF(Rakudo::QuantHash.BAGGY-CLONE($!elems)), + nqp::create(BagHash) + ) + } + +#--- iterator methods + + sub proxy(Mu \iter,Mu \storage) is raw { + # We are only sure that the key exists when the Proxy + # is made, but we cannot be sure of its existence when + # either the FETCH or STORE block is executed. So we + # still need to check for existence, and handle the case + # where we need to (re-create) the key and value. The + # logic is therefore basically the same as in AT-KEY, + # except for tests for allocated storage and .WHICH + # processing. + nqp::stmts( + (my $which := nqp::iterkey_s(iter)), + # save object for potential recreation + (my $object := nqp::getattr(nqp::iterval(iter),Pair,'$!key')), + + Proxy.new( + FETCH => { + nqp::if( + nqp::existskey(storage,$which), + nqp::getattr(nqp::atkey(storage,$which),Pair,'$!value'), + 0 + ) + }, + STORE => -> $, Int() $value { + nqp::if( + nqp::istype($value,Failure), # RT 128927 + $value.throw, + nqp::if( + nqp::existskey(storage,$which), + nqp::if( # existing element + nqp::isgt_i($value,0), + nqp::bindattr( # value ok + nqp::atkey(storage,$which), + Pair, + '$!value', + nqp::decont($value) + ), + nqp::stmts( # goodbye! + nqp::deletekey(storage,$which), + 0 + ) + ), + nqp::if( # where did it go? + nqp::isgt_i($value,0), + nqp::bindkey( + storage, + $which, + Pair.new($object,nqp::decont($value)) + ) + ) + ) + ) + } + ) + ) + } + + multi method iterator(BagHash:D:) { # also .pairs + class :: does Rakudo::Iterator::Mappy { + method pull-one() is raw { + nqp::if( + $!iter, + nqp::p6bindattrinvres( + nqp::clone(nqp::iterval(nqp::shift($!iter))), + Pair, + '$!value', + proxy($!iter,$!hash) + ), + IterationEnd + ) + } + method push-all($target --> IterationEnd) { + nqp::while( # doesn't sink + $!iter, + $target.push(nqp::iterval(nqp::shift($!iter))) + ) + } + }.new($!elems) + } + + multi method values(BagHash:D:) { + Seq.new(class :: does Rakudo::Iterator::Mappy { + method pull-one() is raw { + nqp::if( + $!iter, + proxy(nqp::shift($!iter),$!hash), + IterationEnd + ) + } + + # same as Baggy.values + method push-all($target --> IterationEnd) { + nqp::while( # doesn't sink + $!iter, + $target.push(nqp::getattr( + nqp::iterval(nqp::shift($!iter)),Pair,'$!value')) + ) + } + }.new($!elems)) + } + + multi method kv(BagHash:D:) { + Seq.new(class :: does Rakudo::Iterator::Mappy-kv-from-pairs { + method pull-one() is raw { + nqp::if( + $!on, + nqp::stmts( + ($!on = 0), + proxy($!iter,$!hash) + ), + nqp::if( + $!iter, + nqp::stmts( + ($!on = 1), + nqp::getattr( + nqp::iterval(nqp::shift($!iter)),Pair,'$!key') + ), + IterationEnd + ) + ) + } + }.new($!elems)) + } + +#---- selection methods + multi method grab(BagHash:D:) { + nqp::if( + $!elems && nqp::elems($!elems), + Rakudo::QuantHash.BAG-GRAB($!elems,self.total), + Nil + ) + } + multi method grab(BagHash:D: Callable:D $calculate) { + self.grab( $calculate(self.total) ) + } + multi method grab(BagHash:D: Whatever) { self.grab(Inf) } + multi method grab(BagHash:D: $count) { + Seq.new(nqp::if( + (my $todo = Rakudo::QuantHash.TODO($count)) + && $!elems + && nqp::elems($!elems), + nqp::stmts( + (my Int $total = self.total), + nqp::if($todo > $total,$todo = $total), + Rakudo::Iterator.Callable( { + nqp::if( + $todo, + nqp::stmts( + --$todo, + Rakudo::QuantHash.BAG-GRAB($!elems,$total--) + ), + IterationEnd + ) + } ) + ), + Rakudo::Iterator.Empty + )) + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Bag.pm rakudo-2018.03/src/core/Bag.pm --- rakudo-2018.02.1/src/core/Bag.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Bag.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,91 +0,0 @@ -my class Bag does Baggy { - has Int $!total; - has $!WHICH; - -#--- introspection methods - multi method WHICH(Bag:D:) { - nqp::if( - nqp::attrinited(self,Bag,'$!WHICH'), - $!WHICH, - $!WHICH := ValueObjAt.new('Bag!' ~ nqp::sha1( - nqp::join('\0',Rakudo::Sorting.MERGESORT-str( - Rakudo::QuantHash.BAGGY-RAW-KEY-VALUES(self) - )) - )) - ) - } - method total(Bag:D: --> Int:D) { - nqp::if( - nqp::attrinited(self,Bag,'$!total'), - $!total, - $!total := Rakudo::QuantHash.BAG-TOTAL($!elems) - ) - } - -#--- interface methods - method STORE(*@pairs, :$initialize --> Bag:D) { - nqp::if( - (my $iterator := @pairs.iterator).is-lazy, - Failure.new(X::Cannot::Lazy.new(:action,:what(self.^name))), - nqp::if( - $initialize, - self.SET-SELF( - Rakudo::QuantHash.ADD-PAIRS-TO-BAG( - nqp::create(Rakudo::Internals::IterationSet), $iterator - ) - ), - X::Assignment::RO.new(value => self).throw - ) - ) - } - - multi method DELETE-KEY(Bag:D: \k) { - X::Immutable.new(method => 'DELETE-KEY', typename => self.^name).throw; - } - -#--- selection methods - multi method grabpairs(Bag:D: $count?) { - X::Immutable.new( method => 'grabpairs', typename => self.^name ).throw; - } - -#--- coercion methods - multi method Bag(Bag:D:) { self } - multi method BagHash(Bag:D) { - nqp::if( - $!elems && nqp::elems($!elems), - nqp::create(BagHash).SET-SELF(Rakudo::QuantHash.BAGGY-CLONE($!elems)), - nqp::create(BagHash) - ) - } - multi method Mix(Bag:D:) { - nqp::if( - $!elems && nqp::elems($!elems), - nqp::create(Mix).SET-SELF($!elems), - mix() - ) - } - multi method MixHash(Bag:D) { - nqp::if( - $!elems && nqp::elems($!elems), - nqp::create(MixHash).SET-SELF(Rakudo::QuantHash.BAGGY-CLONE($!elems)), - nqp::create(MixHash) - ) - } - method clone() { - nqp::if( - $!elems && nqp::elems($!elems), - nqp::clone(self), - bag() - ) - } - -#--- illegal methods - proto method classify-list(|) { - X::Immutable.new(:method, :typename(self.^name)).throw; - } - proto method categorize-list(|) { - X::Immutable.new(:method, :typename(self.^name)).throw; - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Bag.pm6 rakudo-2018.03/src/core/Bag.pm6 --- rakudo-2018.02.1/src/core/Bag.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Bag.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,91 @@ +my class Bag does Baggy { + has Int $!total; + has $!WHICH; + +#--- introspection methods + multi method WHICH(Bag:D:) { + nqp::if( + nqp::attrinited(self,Bag,'$!WHICH'), + $!WHICH, + $!WHICH := ValueObjAt.new('Bag!' ~ nqp::sha1( + nqp::join('\0',Rakudo::Sorting.MERGESORT-str( + Rakudo::QuantHash.BAGGY-RAW-KEY-VALUES(self) + )) + )) + ) + } + method total(Bag:D: --> Int:D) { + nqp::if( + nqp::attrinited(self,Bag,'$!total'), + $!total, + $!total := Rakudo::QuantHash.BAG-TOTAL($!elems) + ) + } + +#--- interface methods + method STORE(*@pairs, :$initialize --> Bag:D) { + nqp::if( + (my $iterator := @pairs.iterator).is-lazy, + Failure.new(X::Cannot::Lazy.new(:action,:what(self.^name))), + nqp::if( + $initialize, + self.SET-SELF( + Rakudo::QuantHash.ADD-PAIRS-TO-BAG( + nqp::create(Rakudo::Internals::IterationSet), $iterator + ) + ), + X::Assignment::RO.new(value => self).throw + ) + ) + } + + multi method DELETE-KEY(Bag:D: \k) { + X::Immutable.new(method => 'DELETE-KEY', typename => self.^name).throw; + } + +#--- selection methods + multi method grabpairs(Bag:D: $count?) { + X::Immutable.new( method => 'grabpairs', typename => self.^name ).throw; + } + +#--- coercion methods + multi method Bag(Bag:D:) { self } + multi method BagHash(Bag:D) { + nqp::if( + $!elems && nqp::elems($!elems), + nqp::create(BagHash).SET-SELF(Rakudo::QuantHash.BAGGY-CLONE($!elems)), + nqp::create(BagHash) + ) + } + multi method Mix(Bag:D:) { + nqp::if( + $!elems && nqp::elems($!elems), + nqp::create(Mix).SET-SELF($!elems), + mix() + ) + } + multi method MixHash(Bag:D) { + nqp::if( + $!elems && nqp::elems($!elems), + nqp::create(MixHash).SET-SELF(Rakudo::QuantHash.BAGGY-CLONE($!elems)), + nqp::create(MixHash) + ) + } + method clone() { + nqp::if( + $!elems && nqp::elems($!elems), + nqp::clone(self), + bag() + ) + } + +#--- illegal methods + proto method classify-list(|) { + X::Immutable.new(:method, :typename(self.^name)).throw; + } + proto method categorize-list(|) { + X::Immutable.new(:method, :typename(self.^name)).throw; + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Block.pm rakudo-2018.03/src/core/Block.pm --- rakudo-2018.02.1/src/core/Block.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Block.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,350 +0,0 @@ -my class Block { # declared in BOOTSTRAP - # class Block is Code - # has Mu $!phasers; - # has Mu $!why; - - method of(Block:D:) { nqp::getattr(self,Code,'$!signature').returns } - method returns(Block:D:) { nqp::getattr(self,Code,'$!signature').returns } - - method add_phaser(Str:D \name, &block --> Nil) { - $!phasers := nqp::hash - unless nqp::attrinited(self,Block,'$!phasers'); - - my str $name = name; - nqp::bindkey($!phasers,$name,nqp::create(IterationBuffer)) - unless nqp::existskey($!phasers,$name); - - if nqp::iseq_s($name,'LEAVE') || nqp::iseq_s($name,'KEEP') || nqp::iseq_s($name,'UNDO') { - nqp::unshift(nqp::atkey($!phasers,$name),&block); - self.add_phaser('!LEAVE-ORDER', &block); - } - elsif nqp::iseq_s($name,'NEXT') || nqp::iseq_s($name,'!LEAVE-ORDER') || nqp::iseq_s($name,'POST') { - nqp::unshift(nqp::atkey($!phasers,$name),&block); - } - else { - nqp::push(nqp::atkey($!phasers,$name),&block); - } - } - - method fire_if_phasers(Str $name --> Nil) { - nqp::if( - nqp::attrinited(self,Block,'$!phasers') - && nqp::existskey($!phasers,$name), - nqp::stmts( - (my $iter := nqp::iterator(nqp::atkey($!phasers,$name))), - nqp::while($iter,nqp::shift($iter)(),:nohandler) - ) - ) - } - - method fire_phasers(Str $name --> Nil) { - nqp::stmts( - (my $iter := nqp::iterator(nqp::atkey($!phasers,$name))), - nqp::while($iter,nqp::shift($iter)(),:nohandler) - ) - } - - method has-phasers() { nqp::attrinited(self,Block,'$!phasers') } - - method has-phaser(Str:D \name) { - nqp::attrinited(self,Block,'$!phasers') - && nqp::existskey($!phasers,nqp::unbox_s(name)) - } - - method phasers(Str:D $name) { - nqp::attrinited(self,Block,'$!phasers') - && nqp::existskey($!phasers,nqp::unbox_s($name)) - ?? nqp::p6bindattrinvres(nqp::create(List),List,'$!reified', - nqp::atkey($!phasers,nqp::unbox_s($name))) - !! () - } - - method assuming(Block:D $self: |primers) { - my $sig = nqp::getattr(nqp::decont($self), Code, '$!signature'); - - # A ::() that does not throw. Also does not need to deal - # with chunks or sigils. - my sub soft_indirect_name_lookup($name) { - my @parts = $name.split('::'); - - my Mu $thing := ::.EXISTS-KEY(@parts[0]); - return False unless $thing; - $thing := ::.AT-KEY(@parts.shift); - for @parts { - return False unless $thing.WHO.EXISTS-KEY($_); - $thing := $thing.WHO{$_}; - } - True; - } - - # sub strip-parm - # This is mostly a stripped-down version of Parameter.perl, removing - # where clauses, turning "= { ... }" from defaults into just - # "?", removing type captures, subsignatures, and undeclared types - # (e.g. types set to or parameterized by captured types.) - my sub strip_parm (Parameter:D $parm, :$make_optional = False) { - my $type = $parm.type.^name; - my $perl = $type; - my $rest = ''; - my $sigil = $parm.sigil; - my $elide_agg_cont= so ($sigil eqv '@' - or $sigil eqv '%' - or $type ~~ /^^ Callable >> /); - - $perl = '' if $elide_agg_cont; - unless $type eq "Any" { - my int $FIRST = 1; # broken FIRST workaround - while ($type ~~ / (.*?) \[ (.*) \] $$/) { -# FIRST { # seems broken in setting - if $FIRST { # broken FIRST workaround - $perl = $elide_agg_cont - ?? ~$1 - !! ~$/; - $FIRST = 0; - } - $type = ~$1; - unless soft_indirect_name_lookup(~$0) { - $perl = ''; - last - }; - } - $perl = '' unless soft_indirect_name_lookup($type); - } - $perl ~= $parm.modifier if $perl ne ''; - - my $name = $parm.name; - if !$name and $parm.raw { - $name = '$'; - } elsif !$name or !$name.starts-with($sigil) { - $name = $sigil ~ $parm.twigil ~ ($name // ''); - } - - if $parm.slurpy { - $name = '*' ~ $name; - } elsif $parm.named { - my @names := $parm.named_names; - $name = ':' ~ $_ ~ '(' ~ $name ~ ')'for @names; - $name ~= '!' unless ($parm.optional or $make_optional); - $name ~= '?' if ($make_optional); - } elsif $parm.optional or $parm.default { - $name ~= '?'; - } - - if $parm.rw { - $rest ~= ' is rw'; - } elsif $parm.copy { - $rest ~= ' is copy'; - } - if $parm.raw { - $rest ~= ' is raw' unless $name.starts-with('\\'); - } - if $name or $rest { - $perl ~= ($perl ?? ' ' !! '') ~ $name; - } - $perl ~ $rest; - } - - # If we have only one parameter and it is a capture with a - # subsignature, we might as will jump down into it. - while +$sig.params == 1 - and $sig.params[0].capture - and $sig.params[0].sub_signature { - $sig = $sig.params[0].sub_signature; - } - - my @plist = (); # Positionals in the returned closure's signature - my @clist = (); # The positional args used to call the original code - my @tlist = (); # Positional params to verify binding primers against - my @alist = (); # Primers as positional arguments after processing - - # Find a name safe to use across slurpies, captures and sigilless - my $safename = '_'; - $safename ~= '_' while $sig.params.first: - { $_.name.defined and $_.name eq $safename and - ($_.slurpy or $_.sigil eq '\\' or $_.sigil eq '|') }; - my $capwrap = $safename ~ '_'; - $capwrap ~= '_' while $sig.params.first: - { $_.name.defined and $_.name eq $capwrap and - ($_.slurpy or $_.sigil eq '\\' or $_.sigil eq '|') }; - - - # Look for slurpies and captures - my $slurp_p = $sig.params.first: {.slurpy and .sigil eq '@'}; - my $slurp_n = $sig.params.first: {.slurpy and .sigil eq '%'}; - $slurp_p //= (); - $slurp_n //= (); - - # This gets sticky. A bare capture will take anything - # you throw at it. A capture with a subsignature, not always. - # Both will raise Signature.count to Inf, unfortunately, - # and neither counts towards Signature.arity. That might - # eventually change as it is LTA. - # - # We have no real use for any captures defined in the original - # signature, but if there is one, we must emulate its slurpylike - # effects. We cannot tell if it actually has slurpylike - # effects without looking at subsignatures, recursively, - # but really Signature should be able to tell us that. - # - # Until then, we will add slurpy behaviors, assuming we - # do not already have them, if we see a capture. - my $need_cap = ($sig.count == Inf and not ($slurp_p and $slurp_n)); - if $need_cap { - $need_cap = False; - for $sig.params.grep(*.capture) { - $need_cap = True; - last; - } - } - # For now this is how we fabricate parameters. - my &safeparms = EVAL - sprintf('sub (|%s) { }', $safename); - if ($need_cap) { - $slurp_p ||= &safeparms.signature.params[0]; - $slurp_n ||= &safeparms.signature.params[0]; - } - # Normal Positionals - my Int $idx = -1; - for $sig.params.grep(*.positional) -> $parm { - ++$idx; - unless $idx < primers.list.elems { - @plist.push($parm); - @clist.push($capwrap ~ '[' ~ @plist.end ~ ']'); - next; - } - given primers.list[$idx] { - when Whatever { @plist.push($parm); - @clist.push($capwrap ~ '[' ~ @plist.end ~ ']'); - } - when Nil { @alist.push($parm.type); - @clist.push($parm.type.^name); - @tlist.push($parm); - } - default { @alist.push($_); - @clist.push("primers.list[$idx]"); - @tlist.push($parm); - } - } - } - my $widx = @plist.end; - @tlist.push($slurp_p) if $slurp_p; - @plist.push($slurp_p) if $slurp_p and not $slurp_p.capture; - - ++$idx; - my $cidx = 0; - - # Even if we prime above the arity, do it anyway, for errors. - while ($idx < primers.list.elems) { - given primers.list[$idx] { - when Whatever { - @clist.push($capwrap ~ '[' ~ ++$widx ~ ']'); - } - when Nil { - my $t = "Any"; - if $slurp_p { - unless $slurp_p.capture { - $t = $slurp_p.type.of.^name - } - } - @alist.push($t); - @clist.push($t); - } - default { - @alist.push($_); - @clist.push("primers.list[$idx]"); - } - } - ++$idx; - } - if $slurp_p { - @clist.push('|' ~ $capwrap ~ '[' ~ ++$widx ~ '..*-1]' ); - # If it is a true slurpy we already pushed it to $plist - $slurp_p = () unless $slurp_p.capture; - } - - # Normal Nameds. - # I noted this: - # perl6 -e 'sub a (*%A, :$a?, *%B) { %A.say; %B.say }; a(:a(1));' - # {:a(1)}<> - # {}<> - # I am going to treat that as a feature and preserve the behavior. - # So we will care for ordering of the named parameters in the - # user-facing signature as well, for introspection purposes. - my %ahash = primers.hash; - my @phash = $sig.params.grep: *.named; - my @thash = $sig.params.grep: { - .named and ( - .slurpy or - any(%ahash.keys) eq any(.named_names.list) - ) - } - @phash .= map: { - my @names = .named_names.list; - my $p = strip_parm($_); - if not .optional and any(%ahash.keys) eq any(@names) { - # Make mandatory parameters optional once they have - # been supplied at least once. - $p = strip_parm($_, :make_optional); - } - $p; - } - if ($slurp_n and $slurp_n.capture and !($slurp_n === $slurp_p)) { - @phash.push(strip_parm($slurp_n)); - } - my $error = False; - EVAL(sprintf('anon sub trybind (%s) { }(|@alist, |%%ahash);', - (flat @tlist.map(&strip_parm), - @thash.map(&strip_parm)).join(", ")) - ); - - my $f; - my $primed_sig = (flat @plist.map(&strip_parm), @phash, - ($slurp_p ?? strip_parm($slurp_p) !! ())).join(", "); - $primed_sig ~= ' --> ' ~ $sig.returns.^name; - - $f = EVAL sprintf( - '{ my $res = (my proto __PRIMED_ANON (%s) { {*} }); - my multi __PRIMED_ANON (|%s(%s)) { - my %%chash := %s.hash; - $self(%s%s |{ %%ahash, %%chash }); # |{} workaround RT#77788 - }; - $res }()', - $primed_sig, $capwrap, $primed_sig, $capwrap, - (flat @clist).join(", "), - (@clist ?? ',' !! '') - ); - - $error ~~ Exception ?? $f but Failure.new($error) !! $f; - } - - multi method perl(Block:D:) { - "-> {self.signature.perl.substr(2,*-1)} \{ #`({self.WHICH}) ... \}" - } - - method WHY() { - if nqp::isnull($!why) { - nextsame - } else { - $!why.set_docee(self); - $!why - } - } - - method set_why($why --> Nil) { - $!why := $why; - } - - # helper method for array slicing - method pos(Block:D $self: \list) { - nqp::if( - (nqp::istype( - (my $n := nqp::getattr( - nqp::getattr($self,Code,'$!signature'),Signature,'$!count') - ),Num) && nqp::isnanorinf($n)) || nqp::iseq_i(nqp::unbox_i($n),1), - $self(nqp::if(nqp::isconcrete(list),list.elems,0)), - $self(|(nqp::if(nqp::isconcrete(list),list.elems,0) xx $n)) - ) - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Block.pm6 rakudo-2018.03/src/core/Block.pm6 --- rakudo-2018.02.1/src/core/Block.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Block.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,350 @@ +my class Block { # declared in BOOTSTRAP + # class Block is Code + # has Mu $!phasers; + # has Mu $!why; + + method of(Block:D:) { nqp::getattr(self,Code,'$!signature').returns } + method returns(Block:D:) { nqp::getattr(self,Code,'$!signature').returns } + + method add_phaser(Str:D \name, &block --> Nil) { + $!phasers := nqp::hash + unless nqp::attrinited(self,Block,'$!phasers'); + + my str $name = name; + nqp::bindkey($!phasers,$name,nqp::create(IterationBuffer)) + unless nqp::existskey($!phasers,$name); + + if nqp::iseq_s($name,'LEAVE') || nqp::iseq_s($name,'KEEP') || nqp::iseq_s($name,'UNDO') { + nqp::unshift(nqp::atkey($!phasers,$name),&block); + self.add_phaser('!LEAVE-ORDER', &block); + } + elsif nqp::iseq_s($name,'NEXT') || nqp::iseq_s($name,'!LEAVE-ORDER') || nqp::iseq_s($name,'POST') { + nqp::unshift(nqp::atkey($!phasers,$name),&block); + } + else { + nqp::push(nqp::atkey($!phasers,$name),&block); + } + } + + method fire_if_phasers(Str $name --> Nil) { + nqp::if( + nqp::attrinited(self,Block,'$!phasers') + && nqp::existskey($!phasers,$name), + nqp::stmts( + (my $iter := nqp::iterator(nqp::atkey($!phasers,$name))), + nqp::while($iter,nqp::shift($iter)(),:nohandler) + ) + ) + } + + method fire_phasers(Str $name --> Nil) { + nqp::stmts( + (my $iter := nqp::iterator(nqp::atkey($!phasers,$name))), + nqp::while($iter,nqp::shift($iter)(),:nohandler) + ) + } + + method has-phasers() { nqp::attrinited(self,Block,'$!phasers') } + + method has-phaser(Str:D \name) { + nqp::attrinited(self,Block,'$!phasers') + && nqp::existskey($!phasers,nqp::unbox_s(name)) + } + + method phasers(Str:D $name) { + nqp::attrinited(self,Block,'$!phasers') + && nqp::existskey($!phasers,nqp::unbox_s($name)) + ?? nqp::p6bindattrinvres(nqp::create(List),List,'$!reified', + nqp::atkey($!phasers,nqp::unbox_s($name))) + !! () + } + + method assuming(Block:D $self: |primers) { + my $sig = nqp::getattr(nqp::decont($self), Code, '$!signature'); + + # A ::() that does not throw. Also does not need to deal + # with chunks or sigils. + my sub soft_indirect_name_lookup($name) { + my @parts = $name.split('::'); + + my Mu $thing := ::.EXISTS-KEY(@parts[0]); + return False unless $thing; + $thing := ::.AT-KEY(@parts.shift); + for @parts { + return False unless $thing.WHO.EXISTS-KEY($_); + $thing := $thing.WHO{$_}; + } + True; + } + + # sub strip-parm + # This is mostly a stripped-down version of Parameter.perl, removing + # where clauses, turning "= { ... }" from defaults into just + # "?", removing type captures, subsignatures, and undeclared types + # (e.g. types set to or parameterized by captured types.) + my sub strip_parm (Parameter:D $parm, :$make_optional = False) { + my $type = $parm.type.^name; + my $perl = $type; + my $rest = ''; + my $sigil = $parm.sigil; + my $elide_agg_cont= so ($sigil eqv '@' + or $sigil eqv '%' + or $type ~~ /^^ Callable >> /); + + $perl = '' if $elide_agg_cont; + unless $type eq "Any" { + my int $FIRST = 1; # broken FIRST workaround + while ($type ~~ / (.*?) \[ (.*) \] $$/) { +# FIRST { # seems broken in setting + if $FIRST { # broken FIRST workaround + $perl = $elide_agg_cont + ?? ~$1 + !! ~$/; + $FIRST = 0; + } + $type = ~$1; + unless soft_indirect_name_lookup(~$0) { + $perl = ''; + last + }; + } + $perl = '' unless soft_indirect_name_lookup($type); + } + $perl ~= $parm.modifier if $perl ne ''; + + my $name = $parm.name; + if !$name and $parm.raw { + $name = '$'; + } elsif !$name or !$name.starts-with($sigil) { + $name = $sigil ~ $parm.twigil ~ ($name // ''); + } + + if $parm.slurpy { + $name = '*' ~ $name; + } elsif $parm.named { + my @names := $parm.named_names; + $name = ':' ~ $_ ~ '(' ~ $name ~ ')'for @names; + $name ~= '!' unless ($parm.optional or $make_optional); + $name ~= '?' if ($make_optional); + } elsif $parm.optional or $parm.default { + $name ~= '?'; + } + + if $parm.rw { + $rest ~= ' is rw'; + } elsif $parm.copy { + $rest ~= ' is copy'; + } + if $parm.raw { + $rest ~= ' is raw' unless $name.starts-with('\\'); + } + if $name or $rest { + $perl ~= ($perl ?? ' ' !! '') ~ $name; + } + $perl ~ $rest; + } + + # If we have only one parameter and it is a capture with a + # subsignature, we might as will jump down into it. + while +$sig.params == 1 + and $sig.params[0].capture + and $sig.params[0].sub_signature { + $sig = $sig.params[0].sub_signature; + } + + my @plist = (); # Positionals in the returned closure's signature + my @clist = (); # The positional args used to call the original code + my @tlist = (); # Positional params to verify binding primers against + my @alist = (); # Primers as positional arguments after processing + + # Find a name safe to use across slurpies, captures and sigilless + my $safename = '_'; + $safename ~= '_' while $sig.params.first: + { $_.name.defined and $_.name eq $safename and + ($_.slurpy or $_.sigil eq '\\' or $_.sigil eq '|') }; + my $capwrap = $safename ~ '_'; + $capwrap ~= '_' while $sig.params.first: + { $_.name.defined and $_.name eq $capwrap and + ($_.slurpy or $_.sigil eq '\\' or $_.sigil eq '|') }; + + + # Look for slurpies and captures + my $slurp_p = $sig.params.first: {.slurpy and .sigil eq '@'}; + my $slurp_n = $sig.params.first: {.slurpy and .sigil eq '%'}; + $slurp_p //= (); + $slurp_n //= (); + + # This gets sticky. A bare capture will take anything + # you throw at it. A capture with a subsignature, not always. + # Both will raise Signature.count to Inf, unfortunately, + # and neither counts towards Signature.arity. That might + # eventually change as it is LTA. + # + # We have no real use for any captures defined in the original + # signature, but if there is one, we must emulate its slurpylike + # effects. We cannot tell if it actually has slurpylike + # effects without looking at subsignatures, recursively, + # but really Signature should be able to tell us that. + # + # Until then, we will add slurpy behaviors, assuming we + # do not already have them, if we see a capture. + my $need_cap = ($sig.count == Inf and not ($slurp_p and $slurp_n)); + if $need_cap { + $need_cap = False; + for $sig.params.grep(*.capture) { + $need_cap = True; + last; + } + } + # For now this is how we fabricate parameters. + my &safeparms = EVAL + sprintf('sub (|%s) { }', $safename); + if ($need_cap) { + $slurp_p ||= &safeparms.signature.params[0]; + $slurp_n ||= &safeparms.signature.params[0]; + } + # Normal Positionals + my Int $idx = -1; + for $sig.params.grep(*.positional) -> $parm { + ++$idx; + unless $idx < primers.list.elems { + @plist.push($parm); + @clist.push($capwrap ~ '[' ~ @plist.end ~ ']'); + next; + } + given primers.list[$idx] { + when Whatever { @plist.push($parm); + @clist.push($capwrap ~ '[' ~ @plist.end ~ ']'); + } + when Nil { @alist.push($parm.type); + @clist.push($parm.type.^name); + @tlist.push($parm); + } + default { @alist.push($_); + @clist.push("primers.list[$idx]"); + @tlist.push($parm); + } + } + } + my $widx = @plist.end; + @tlist.push($slurp_p) if $slurp_p; + @plist.push($slurp_p) if $slurp_p and not $slurp_p.capture; + + ++$idx; + my $cidx = 0; + + # Even if we prime above the arity, do it anyway, for errors. + while ($idx < primers.list.elems) { + given primers.list[$idx] { + when Whatever { + @clist.push($capwrap ~ '[' ~ ++$widx ~ ']'); + } + when Nil { + my $t = "Any"; + if $slurp_p { + unless $slurp_p.capture { + $t = $slurp_p.type.of.^name + } + } + @alist.push($t); + @clist.push($t); + } + default { + @alist.push($_); + @clist.push("primers.list[$idx]"); + } + } + ++$idx; + } + if $slurp_p { + @clist.push('|' ~ $capwrap ~ '[' ~ ++$widx ~ '..*-1]' ); + # If it is a true slurpy we already pushed it to $plist + $slurp_p = () unless $slurp_p.capture; + } + + # Normal Nameds. + # I noted this: + # perl6 -e 'sub a (*%A, :$a?, *%B) { %A.say; %B.say }; a(:a(1));' + # {:a(1)}<> + # {}<> + # I am going to treat that as a feature and preserve the behavior. + # So we will care for ordering of the named parameters in the + # user-facing signature as well, for introspection purposes. + my %ahash = primers.hash; + my @phash = $sig.params.grep: *.named; + my @thash = $sig.params.grep: { + .named and ( + .slurpy or + any(%ahash.keys) eq any(.named_names.list) + ) + } + @phash .= map: { + my @names = .named_names.list; + my $p = strip_parm($_); + if not .optional and any(%ahash.keys) eq any(@names) { + # Make mandatory parameters optional once they have + # been supplied at least once. + $p = strip_parm($_, :make_optional); + } + $p; + } + if ($slurp_n and $slurp_n.capture and !($slurp_n === $slurp_p)) { + @phash.push(strip_parm($slurp_n)); + } + my $error = False; + EVAL(sprintf('anon sub trybind (%s) { }(|@alist, |%%ahash);', + (flat @tlist.map(&strip_parm), + @thash.map(&strip_parm)).join(", ")) + ); + + my $f; + my $primed_sig = (flat @plist.map(&strip_parm), @phash, + ($slurp_p ?? strip_parm($slurp_p) !! ())).join(", "); + $primed_sig ~= ' --> ' ~ $sig.returns.^name; + + $f = EVAL sprintf( + '{ my $res = (my proto __PRIMED_ANON (%s) { {*} }); + my multi __PRIMED_ANON (|%s(%s)) { + my %%chash := %s.hash; + $self(%s%s |{ %%ahash, %%chash }); # |{} workaround RT#77788 + }; + $res }()', + $primed_sig, $capwrap, $primed_sig, $capwrap, + (flat @clist).join(", "), + (@clist ?? ',' !! '') + ); + + $error ~~ Exception ?? $f but Failure.new($error) !! $f; + } + + multi method perl(Block:D:) { + "-> {self.signature.perl.substr(2,*-1)} \{ #`({self.WHICH}) ... \}" + } + + method WHY() { + if nqp::isnull($!why) { + nextsame + } else { + $!why.set_docee(self); + $!why + } + } + + method set_why($why --> Nil) { + $!why := $why; + } + + # helper method for array slicing + method pos(Block:D $self: \list) { + nqp::if( + (nqp::istype( + (my $n := nqp::getattr( + nqp::getattr($self,Code,'$!signature'),Signature,'$!count') + ),Num) && nqp::isnanorinf($n)) || nqp::iseq_i(nqp::unbox_i($n),1), + $self(nqp::if(nqp::isconcrete(list),list.elems,0)), + $self(|(nqp::if(nqp::isconcrete(list),list.elems,0) xx $n)) + ) + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Bool.pm rakudo-2018.03/src/core/Bool.pm --- rakudo-2018.02.1/src/core/Bool.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Bool.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,148 +0,0 @@ -# enum Bool declared in BOOTSTRAP -BEGIN { - Bool.^add_method('Bool', my proto method Bool(|) {*}); - Bool.^add_method('gist', my proto method gist(|) {*}); - Bool.^add_method('Numeric', my proto method Numeric(|) {*}); - Bool.^add_method('Int', my proto method Int(|) {*}); - Bool.^add_method('ACCEPTS', my proto method ACCEPTS(|) {*}); - Bool.^add_method('pick', my proto method pick(|) {*}); - Bool.^add_method('roll', my proto method roll(|) {*}); - Bool.^add_method('perl', my proto method perl(|) {*}); -} -BEGIN { - Bool.^add_multi_method('Bool', my multi method Bool(Bool:D:) { self }); - Bool.^add_multi_method('gist', my multi method gist(Bool:D:) { self ?? 'True' !! 'False' }); - Bool.^add_multi_method('Str', my multi method Str(Bool:D:) { self ?? 'True' !! 'False' }); - Bool.^add_multi_method('Numeric', my multi method Numeric(Bool:D:) { self ?? 1 !! 0 }); - Bool.^add_multi_method('Int', my multi method Int(Bool:D:) { self ?? 1 !! 0 }); - Bool.^add_multi_method('Real', my multi method Real(Bool:D:) { self ?? 1 !! 0 }); - Bool.^add_multi_method('ACCEPTS', my multi method ACCEPTS(Bool:D: Mu \topic ) { self }); - Bool.^add_multi_method('perl', my multi method perl(Bool:D:) { self ?? 'Bool::True' !! 'Bool::False' }); - - Bool.^add_multi_method('pick', my multi method pick(Bool:U:) { nqp::p6bool(nqp::isge_n(nqp::rand_n(2e0), 1e0)) }); - Bool.^add_multi_method('roll', my multi method roll(Bool:U:) { nqp::p6bool(nqp::isge_n(nqp::rand_n(2e0), 1e0)) }); -} -BEGIN { - Bool.^add_multi_method('Bool', my multi method Bool(Bool:U:) { Bool::False }); - Bool.^add_multi_method('ACCEPTS', my multi method ACCEPTS(Bool:U: \topic ) { nqp::istype(topic, Bool) }); - Bool.^add_multi_method('gist', my multi method gist(Bool:U:) { '(Bool)' }); - Bool.^add_multi_method('perl', my multi method perl(Bool:U:) { 'Bool' }); - - Bool.^add_multi_method('pick', my multi method pick(Bool:U: $n) { self.^enum_value_list.pick($n) }); - Bool.^add_multi_method('roll', my multi method roll(Bool:U: $n) { self.^enum_value_list.roll($n) }); - - Bool.^add_method('pred', my method pred() { Bool::False }); - Bool.^add_method('succ', my method succ() { Bool::True }); - - Bool.^add_method('enums', my method enums() { self.^enum_values.Map }); - - Bool.^compose; -} - -multi sub prefix:<++>(Bool $a is rw) { $a = True; } -multi sub prefix:<-->(Bool $a is rw) { $a = False; } -multi sub postfix:<++>(Bool:U $a is rw --> False) { $a = True } -multi sub postfix:<-->(Bool:U $a is rw) { $a = False; } - -multi sub postfix:<++>(Bool:D $a is rw) { - if $a { - True - } - else { - $a = True; - False - } -} -multi sub postfix:<-->(Bool:D $a is rw) { - if $a { - $a = False; - True - } - else { - False - } -} - -proto sub prefix:(Mu $) is pure {*} -multi sub prefix:(Bool:D \a) { a } -multi sub prefix:(Bool:U \a) { Bool::False } -multi sub prefix:(Mu \a) { a.Bool } - -proto sub prefix:(Mu $) is pure {*} -multi sub prefix:(Bool:D \a) { a } -multi sub prefix:(Bool:U \a) { Bool::False } -multi sub prefix:(Mu \a) { a.Bool } - -proto sub prefix:(Mu $) is pure {*} -multi sub prefix:(Bool \a) { nqp::p6bool(nqp::not_i(nqp::istrue(a))) } -multi sub prefix:(Mu \a) { nqp::p6bool(nqp::not_i(nqp::istrue(a))) } - -proto sub prefix:(Mu $) is pure {*} -multi sub prefix:(Bool \a) { nqp::p6bool(nqp::not_i(nqp::istrue(a))) } -multi sub prefix:(Mu \a) { nqp::p6bool(nqp::not_i(nqp::istrue(a))) } - -proto sub prefix:(Mu $) is pure {*} -multi sub prefix:(Mu \a) { not a } - -proto sub infix:(Mu $?, Mu $?) is pure {*} -multi sub infix:(Mu $x = Bool::True) { $x.Bool } -multi sub infix:(Mu \a, Mu \b) { a.Bool && b.Bool } - -proto sub infix:(Mu $?, Mu $?) is pure {*} -multi sub infix:(Mu $x = Bool::False) { $x.Bool } -multi sub infix:(Mu \a, Mu \b) { a.Bool || b.Bool } - -proto sub infix:(Mu $?, Mu $?) is pure {*} -multi sub infix:(Mu $x = Bool::False) { $x.Bool } -multi sub infix:(Mu \a, Mu \b) { nqp::p6bool(nqp::ifnull(nqp::xor(a.Bool,b.Bool), 0)) } - -# These operators are normally handled as macros in the compiler; -# we define them here for use as arguments to functions. -proto sub infix:<&&>(|) {*} -multi sub infix:<&&>(Mu $x = Bool::True) { $x } -multi sub infix:<&&>(Mu \a, &b) { a && b() } -multi sub infix:<&&>(Mu \a, Mu \b) { a && b } - -proto sub infix:<||>(|) {*} -multi sub infix:<||>(Mu $x = Bool::False) { $x } -multi sub infix:<||>(Mu \a, &b) { a || b() } -multi sub infix:<||>(Mu \a, Mu \b) { a || b } - -proto sub infix:<^^>(|) {*} -multi sub infix:<^^>(Mu $x = Bool::False) { $x } -multi sub infix:<^^>(Mu \a, &b) { a ^^ b() } -multi sub infix:<^^>(Mu \a, Mu \b) { a ^^ b } -multi sub infix:<^^>(+@a) { - my Mu $a = shift @a; - while @a { - my Mu $b := shift @a; - $b := $b() if $b ~~ Callable; - next unless $b; - return Nil if $a; - $a := $b; - } - $a; -} - -proto sub infix:(|) {*} -multi sub infix:(Mu $x = Any) { $x } -multi sub infix:(Mu \a, &b) { a // b } -multi sub infix:(Mu \a, Mu \b) { a // b } - -proto sub infix:(|) {*} -multi sub infix:(Mu $x = Bool::True) { $x } -multi sub infix:(Mu \a, &b) { a && b } -multi sub infix:(Mu \a, Mu \b) { a && b } - -proto sub infix:(|) {*} -multi sub infix:(Mu $x = Bool::False) { $x } -multi sub infix:(Mu \a, &b) { a || b } -multi sub infix:(Mu \a, Mu \b) { a || b } - -proto sub infix:(|) {*} -multi sub infix:(Mu $x = Bool::False) { $x } -multi sub infix:(Mu \a, &b) { a ^^ b } -multi sub infix:(Mu \a, Mu \b) { a ^^ b } -multi sub infix:(|c) { &infix:<^^>(|c); } - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Bool.pm6 rakudo-2018.03/src/core/Bool.pm6 --- rakudo-2018.02.1/src/core/Bool.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Bool.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,148 @@ +# enum Bool declared in BOOTSTRAP +BEGIN { + Bool.^add_method('Bool', my proto method Bool(|) {*}); + Bool.^add_method('gist', my proto method gist(|) {*}); + Bool.^add_method('Numeric', my proto method Numeric(|) {*}); + Bool.^add_method('Int', my proto method Int(|) {*}); + Bool.^add_method('ACCEPTS', my proto method ACCEPTS(|) {*}); + Bool.^add_method('pick', my proto method pick(|) {*}); + Bool.^add_method('roll', my proto method roll(|) {*}); + Bool.^add_method('perl', my proto method perl(|) {*}); +} +BEGIN { + Bool.^add_multi_method('Bool', my multi method Bool(Bool:D:) { self }); + Bool.^add_multi_method('gist', my multi method gist(Bool:D:) { self ?? 'True' !! 'False' }); + Bool.^add_multi_method('Str', my multi method Str(Bool:D:) { self ?? 'True' !! 'False' }); + Bool.^add_multi_method('Numeric', my multi method Numeric(Bool:D:) { self ?? 1 !! 0 }); + Bool.^add_multi_method('Int', my multi method Int(Bool:D:) { self ?? 1 !! 0 }); + Bool.^add_multi_method('Real', my multi method Real(Bool:D:) { self ?? 1 !! 0 }); + Bool.^add_multi_method('ACCEPTS', my multi method ACCEPTS(Bool:D: Mu \topic ) { self }); + Bool.^add_multi_method('perl', my multi method perl(Bool:D:) { self ?? 'Bool::True' !! 'Bool::False' }); + + Bool.^add_multi_method('pick', my multi method pick(Bool:U:) { nqp::p6bool(nqp::isge_n(nqp::rand_n(2e0), 1e0)) }); + Bool.^add_multi_method('roll', my multi method roll(Bool:U:) { nqp::p6bool(nqp::isge_n(nqp::rand_n(2e0), 1e0)) }); +} +BEGIN { + Bool.^add_multi_method('Bool', my multi method Bool(Bool:U:) { Bool::False }); + Bool.^add_multi_method('ACCEPTS', my multi method ACCEPTS(Bool:U: \topic ) { nqp::istype(topic, Bool) }); + Bool.^add_multi_method('gist', my multi method gist(Bool:U:) { '(Bool)' }); + Bool.^add_multi_method('perl', my multi method perl(Bool:U:) { 'Bool' }); + + Bool.^add_multi_method('pick', my multi method pick(Bool:U: $n) { self.^enum_value_list.pick($n) }); + Bool.^add_multi_method('roll', my multi method roll(Bool:U: $n) { self.^enum_value_list.roll($n) }); + + Bool.^add_method('pred', my method pred() { Bool::False }); + Bool.^add_method('succ', my method succ() { Bool::True }); + + Bool.^add_method('enums', my method enums() { self.^enum_values.Map }); + + Bool.^compose; +} + +multi sub prefix:<++>(Bool $a is rw) { $a = True; } +multi sub prefix:<-->(Bool $a is rw) { $a = False; } +multi sub postfix:<++>(Bool:U $a is rw --> False) { $a = True } +multi sub postfix:<-->(Bool:U $a is rw) { $a = False; } + +multi sub postfix:<++>(Bool:D $a is rw) { + if $a { + True + } + else { + $a = True; + False + } +} +multi sub postfix:<-->(Bool:D $a is rw) { + if $a { + $a = False; + True + } + else { + False + } +} + +proto sub prefix:(Mu $) is pure {*} +multi sub prefix:(Bool:D \a) { a } +multi sub prefix:(Bool:U \a) { Bool::False } +multi sub prefix:(Mu \a) { a.Bool } + +proto sub prefix:(Mu $) is pure {*} +multi sub prefix:(Bool:D \a) { a } +multi sub prefix:(Bool:U \a) { Bool::False } +multi sub prefix:(Mu \a) { a.Bool } + +proto sub prefix:(Mu $) is pure {*} +multi sub prefix:(Bool \a) { nqp::p6bool(nqp::not_i(nqp::istrue(a))) } +multi sub prefix:(Mu \a) { nqp::p6bool(nqp::not_i(nqp::istrue(a))) } + +proto sub prefix:(Mu $) is pure {*} +multi sub prefix:(Bool \a) { nqp::p6bool(nqp::not_i(nqp::istrue(a))) } +multi sub prefix:(Mu \a) { nqp::p6bool(nqp::not_i(nqp::istrue(a))) } + +proto sub prefix:(Mu $) is pure {*} +multi sub prefix:(Mu \a) { not a } + +proto sub infix:(Mu $?, Mu $?) is pure {*} +multi sub infix:(Mu $x = Bool::True) { $x.Bool } +multi sub infix:(Mu \a, Mu \b) { a.Bool && b.Bool } + +proto sub infix:(Mu $?, Mu $?) is pure {*} +multi sub infix:(Mu $x = Bool::False) { $x.Bool } +multi sub infix:(Mu \a, Mu \b) { a.Bool || b.Bool } + +proto sub infix:(Mu $?, Mu $?) is pure {*} +multi sub infix:(Mu $x = Bool::False) { $x.Bool } +multi sub infix:(Mu \a, Mu \b) { nqp::p6bool(nqp::ifnull(nqp::xor(a.Bool,b.Bool), 0)) } + +# These operators are normally handled as macros in the compiler; +# we define them here for use as arguments to functions. +proto sub infix:<&&>(|) {*} +multi sub infix:<&&>(Mu $x = Bool::True) { $x } +multi sub infix:<&&>(Mu \a, &b) { a && b() } +multi sub infix:<&&>(Mu \a, Mu \b) { a && b } + +proto sub infix:<||>(|) {*} +multi sub infix:<||>(Mu $x = Bool::False) { $x } +multi sub infix:<||>(Mu \a, &b) { a || b() } +multi sub infix:<||>(Mu \a, Mu \b) { a || b } + +proto sub infix:<^^>(|) {*} +multi sub infix:<^^>(Mu $x = Bool::False) { $x } +multi sub infix:<^^>(Mu \a, &b) { a ^^ b() } +multi sub infix:<^^>(Mu \a, Mu \b) { a ^^ b } +multi sub infix:<^^>(+@a) { + my Mu $a = shift @a; + while @a { + my Mu $b := shift @a; + $b := $b() if $b ~~ Callable; + next unless $b; + return Nil if $a; + $a := $b; + } + $a; +} + +proto sub infix:(|) {*} +multi sub infix:(Mu $x = Any) { $x } +multi sub infix:(Mu \a, &b) { a // b } +multi sub infix:(Mu \a, Mu \b) { a // b } + +proto sub infix:(|) {*} +multi sub infix:(Mu $x = Bool::True) { $x } +multi sub infix:(Mu \a, &b) { a && b } +multi sub infix:(Mu \a, Mu \b) { a && b } + +proto sub infix:(|) {*} +multi sub infix:(Mu $x = Bool::False) { $x } +multi sub infix:(Mu \a, &b) { a || b } +multi sub infix:(Mu \a, Mu \b) { a || b } + +proto sub infix:(|) {*} +multi sub infix:(Mu $x = Bool::False) { $x } +multi sub infix:(Mu \a, &b) { a ^^ b } +multi sub infix:(Mu \a, Mu \b) { a ^^ b } +multi sub infix:(|c) { &infix:<^^>(|c); } + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Buf.pm rakudo-2018.03/src/core/Buf.pm --- rakudo-2018.02.1/src/core/Buf.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Buf.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,832 +0,0 @@ -my class X::Buf::AsStr { ... } -my class X::Buf::Pack { ... } -my class X::Buf::Pack::NonASCII { ... } -my class X::Cannot::Empty { ... } -my class X::Cannot::Lazy { ... } -my class X::Experimental { ... } - -my role Blob[::T = uint8] does Positional[T] does Stringy is repr('VMArray') is array_type(T) { - X::NYI.new( - feature => "{$?CLASS.^name.comb(/^ \w+ /)}s with native {T.^name}" - ).throw unless nqp::istype(T,Int); - - # other then *8 not supported yet - my int $bpe = try { -#?if jvm - # https://irclog.perlgeek.de/perl6-dev/2017-01-20#i_13961377 - CATCH { default { Nil } } -#?endif - (T.^nativesize / 8).Int - } // 1; - - multi method WHICH(Blob:D:) { - nqp::box_s( - nqp::concat( - nqp::if( - nqp::eqaddr(self.WHAT,Blob), - 'Blob|', - nqp::concat(nqp::unbox_s(self.^name), '|') - ), - nqp::sha1(self.decode("latin-1")) - ), - ValueObjAt - ) - } - - multi method new(Blob:) { nqp::create(self) } - multi method new(Blob: Blob:D $blob) { - nqp::splice(nqp::create(self),$blob,0,0) - } - multi method new(Blob: int @values) { - nqp::splice(nqp::create(self),@values,0,0) - } - multi method new(Blob: @values) { - @values.is-lazy - ?? Failure.new(X::Cannot::Lazy.new(:action,:what(self.^name))) - !! self!push-list("initializ",nqp::create(self),@values) - } - multi method new(Blob: *@values) { self.new(@values) } - - proto method allocate(|) {*} - multi method allocate(Blob:U: Int:D $elements) { - nqp::setelems(nqp::create(self),$elements) - } - multi method allocate(Blob:U: Int:D $elements, int $value) { - my int $elems = $elements; - my $blob := nqp::setelems(nqp::create(self),$elems); - my int $i = -1; - nqp::bindpos_i($blob,$i,$value) while nqp::islt_i(++$i,$elems); - $blob; - } - multi method allocate(Blob:U: Int:D $elements, Int:D \value) { - my int $value = value; - self.allocate($elements,$value) - } - multi method allocate(Blob:U: Int:D $elements, Mu:D $got) { - self!fail-typecheck('allocate',$got) - } - multi method allocate(Blob:U: Int:D $elements, int @values) { - self!spread(nqp::setelems(nqp::create(self),$elements),@values) - } - multi method allocate(Blob:U: Int:D $elements, Blob:D $blob) { - self!spread(nqp::setelems(nqp::create(self),$elements),$blob) - } - multi method allocate(Blob:U: Int:D $elements, @values) { - self!spread(nqp::setelems(nqp::create(self),$elements),Blob.new(@values)) - } - - multi method EXISTS-POS(Blob:D: int \pos) { - nqp::p6bool( - nqp::islt_i(pos,nqp::elems(self)) && nqp::isge_i(pos,0) - ); - } - multi method EXISTS-POS(Blob:D: Int:D \pos) { - nqp::p6bool( - nqp::islt_i(pos,nqp::elems(self)) && nqp::isge_i(pos,0) - ); - } - - multi method AT-POS(Blob:D: int \pos) { - nqp::if( - (nqp::isge_i(pos,nqp::elems(self)) || nqp::islt_i(pos,0)), - self!fail-range(pos), - nqp::atpos_i(self,pos) - ) - } - multi method AT-POS(Blob:D: Int:D \pos) { - nqp::if( - (nqp::isge_i(pos,nqp::elems(self)) || nqp::islt_i(pos,0)), - self!fail-range(pos), - nqp::atpos_i(self,pos) - ) - } - - multi method Bool(Blob:D:) { nqp::p6bool(nqp::elems(self)) } - method Capture(Blob:D:) { self.List.Capture } - - multi method elems(Blob:D:) { nqp::p6box_i(nqp::elems(self)) } - multi method elems(Blob:U: --> 1) { } - method Numeric(Blob:D:) { nqp::p6box_i(nqp::elems(self)) } - method Int(Blob:D:) { nqp::p6box_i(nqp::elems(self)) } - - method bytes(Blob:D:) { nqp::mul_i(nqp::elems(self),$bpe) } - - method chars(Blob:D:) { X::Buf::AsStr.new(method => 'chars').throw } - multi method Str(Blob:D:) { X::Buf::AsStr.new(method => 'Str' ).throw } - multi method Stringy(Blob:D:) { X::Buf::AsStr.new(method => 'Stringy' ).throw } - - proto method decode(|) {*} - multi method decode(Blob:D:) { - nqp::p6box_s(nqp::decode(self, 'utf8')) - } - multi method decode(Blob:D: $encoding) { - nqp::p6box_s( - nqp::decode(self, Rakudo::Internals.NORMALIZE_ENCODING($encoding))) - } - - multi method list(Blob:D:) { - Seq.new(class :: does Rakudo::Iterator::Blobby { - method pull-one() is raw { - nqp::if( - nqp::islt_i(($!i = nqp::add_i($!i,1)),nqp::elems($!blob)), - nqp::atpos_i($!blob,$!i), - IterationEnd - ) - } - }.new(self)).cache - } - - multi method gist(Blob:D:) { - self.^name ~ ':0x<' ~ self.map( -> \el { - state $i = 0; - ++$i == 101 ?? '...' - !! $i == 102 ?? last() - !! nqp::if(nqp::iseq_i( # el.fmt: '%02x' - nqp::chars(my str $v = nqp::lc(el.base: 16)),1), - nqp::concat('0',$v),$v) - }) ~ '>' - } - multi method perl(Blob:D:) { - self.^name ~ '.new(' ~ self.join(',') ~ ')'; - } - - method subbuf(Blob:D: $from, $length?) { - nqp::stmts( - (my int $elems = nqp::elems(self)), - nqp::if( - $length.DEFINITE && $length < 0, - X::OutOfRange.new( - :what('Len element to subbuf'), :got($length), :range("0..$elems"), - ).fail, - nqp::stmts( - (my int $pos), - (my int $todo), - nqp::if( - nqp::istype($from,Range), - nqp::stmts( - $from.int-bounds($pos, my int $max), - ($todo = nqp::add_i(nqp::sub_i($max, $pos), 1))), - nqp::stmts( - ($pos = nqp::istype($from, Callable) ?? $from($elems) !! $from.Int), - ($todo = $length.DEFINITE ?? $length.Int min $elems - $pos !! $elems - $pos))), - nqp::if( - nqp::islt_i($pos, 0), - X::OutOfRange.new( - :what('From argument to subbuf'), :got($from.gist), :range("0..$elems"), - :comment("use *-{abs $pos} if you want to index relative to the end"), - ).fail, - nqp::if( - nqp::isgt_i($pos, $elems), - X::OutOfRange.new( - :what('From argument to subbuf'), :got($from.gist), :range("0..$elems"), - ).fail, - nqp::if( - nqp::isle_i($todo, 0), - nqp::create(self), # we want zero elements; return empty Blob - nqp::stmts( - (my $subbuf := nqp::create(self)), - nqp::setelems($subbuf, $todo), - (my int $i = -1), - --$pos, - nqp::while( - nqp::islt_i(++$i,$todo), - nqp::bindpos_i($subbuf, $i, nqp::atpos_i(self, ++$pos))), - $subbuf))))))) - } - - method reverse(Blob:D:) { - my int $elems = nqp::elems(self); - my int $last = nqp::sub_i($elems,1); - my $reversed := nqp::setelems(nqp::create(self),$elems); - my int $i = -1; - nqp::while( - nqp::islt_i(($i = nqp::add_i($i,1)),$elems), - nqp::bindpos_i($reversed,nqp::sub_i($last,$i), - nqp::atpos_i(self,$i)) - ); - $reversed - } - - method COMPARE(Blob:D: Blob:D \other) { - my $other := nqp::decont(other); - my int $elems = nqp::elems(self); - if nqp::cmp_i($elems,nqp::elems($other)) -> $diff { - $diff - } - else { - my int $i = -1; - return nqp::cmp_i(nqp::atpos_i(self,$i),nqp::atpos_i($other,$i)) - if nqp::cmp_i(nqp::atpos_i(self,$i),nqp::atpos_i($other,$i)) - while nqp::islt_i(++$i,$elems); - 0 - } - } - - method SAME(Blob:D: Blob:D \other) { - my $other := nqp::decont(other); - my int $elems = nqp::elems(self); - return False unless nqp::iseq_i($elems,nqp::elems($other)); - - my int $i = -1; - return False - unless nqp::iseq_i(nqp::atpos_i(self,$i),nqp::atpos_i($other,$i)) - while nqp::islt_i(++$i,$elems); - - True - } - - method join(Blob:D: $delim = '') { - my int $elems = nqp::elems(self); - my $list := nqp::setelems(nqp::list_s,$elems); - my int $i = -1; - - nqp::bindpos_s($list,$i, - nqp::tostr_I(nqp::p6box_i(nqp::atpos_i(self,$i)))) - while nqp::islt_i(++$i,$elems); - - nqp::join($delim.Str,$list) - } - - proto method unpack(|) {*} - multi method unpack(Blob:D: Str:D $template) { - nqp::isnull(nqp::getlexcaller('EXPERIMENTAL-PACK')) and X::Experimental.new( - feature => "the 'unpack' method", - use => "pack" - ).throw; - self.unpack($template.comb(/<[a..zA..Z]>[\d+|'*']?/)) - } - multi method unpack(Blob:D: @template) { - nqp::isnull(nqp::getlexcaller('EXPERIMENTAL-PACK')) and X::Experimental.new( - feature => "the 'unpack' method", - use => "pack" - ).throw; - my @bytes = self.list; - my @fields; - for @template -> $unit { - my $directive = substr($unit,0,1); - my $amount = substr($unit,1); - my $pa = $amount eq '' ?? 1 !! - $amount eq '*' ?? @bytes.elems !! +$amount; - - given $directive { - when 'a' | 'A' | 'Z' { - @fields.push: @bytes.splice(0, $pa).map(&chr).join; - } - when 'H' { - my str $hexstring = ''; - for ^$pa { - my $byte = shift @bytes; - $hexstring ~= ($byte +> 4).fmt('%x') - ~ ($byte % 16).fmt('%x'); - } - @fields.push($hexstring); - } - when 'x' { - splice @bytes, 0, $pa; - } - when 'C' { - @fields.append: @bytes.splice(0, $pa); - } - when 'S' | 'v' { - for ^$pa { - last if @bytes.elems < 2; - @fields.append: shift(@bytes) - + (shift(@bytes) +< 0x08); - } - } - when 'L' | 'V' { - for ^$pa { - last if @bytes.elems < 4; - @fields.append: shift(@bytes) - + (shift(@bytes) +< 0x08) - + (shift(@bytes) +< 0x10) - + (shift(@bytes) +< 0x18); - } - } - when 'n' { - for ^$pa { - last if @bytes.elems < 2; - @fields.append: (shift(@bytes) +< 0x08) - + shift(@bytes); - } - } - when 'N' { - for ^$pa { - last if @bytes.elems < 4; - @fields.append: (shift(@bytes) +< 0x18) - + (shift(@bytes) +< 0x10) - + (shift(@bytes) +< 0x08) - + shift(@bytes); - } - } - X::Buf::Pack.new(:$directive).throw; - } - } - - return |@fields; - } - - # XXX: the pack.t spectest file seems to require this method - # not sure if it should be changed to list there... - method contents(Blob:D:) { self.list } - - method encoding() { Any } - - method !push-list(\action,\to,\from) { - if nqp::istype(from,List) { - my Mu $from := nqp::getattr(from,List,'$!reified'); - if nqp::defined($from) { - my int $elems = nqp::elems($from); - my int $j = nqp::elems(to); - nqp::setelems(to, $j + $elems); # presize for efficiency - my int $i = -1; - my $got; - nqp::istype(($got := nqp::atpos($from,$i)),Int) - ?? nqp::bindpos_i(to,$j++,$got) - !! self!fail-typecheck-element(action,$i,$got).throw - while nqp::islt_i(++$i,$elems); - } - } - else { - my $iter := from.iterator; - my int $i = 0; - my $got; - until ($got := $iter.pull-one) =:= IterationEnd { - nqp::istype($got,Int) - ?? nqp::push_i(to,$got) - !! self!fail-typecheck-element(action,$i,$got).throw; - ++$i; - } - } - to - } - method !unshift-list(\action,\to,\from) { - if nqp::istype(from,List) { - my Mu $from := nqp::getattr(from,List,'$!reified'); - if nqp::defined($from) { - my int $i = nqp::elems($from); - nqp::istype((my $got := nqp::atpos($from,$i)),Int) - ?? nqp::unshift_i(to,$got) - !! self!fail-typecheck-element(action,$i,$got).throw - while nqp::isge_i(--$i,0); - } - to - } - else { - nqp::splice(to,self!push-list(action,nqp::create(self),from),0,0) - } - } - method !spread(\to,\from) { - if nqp::elems(from) -> int $values { # something to init with - my int $elems = nqp::elems(to) - $values; - my int $i = -$values; - nqp::splice(to,from,$i,$values) - while nqp::isle_i($i = $i + $values,$elems); - - if nqp::isgt_i($i,$elems) { # something left to init - --$i; # went one too far - $elems = $elems + $values; - my int $j = -1; - nqp::bindpos_i(to,$i,nqp::atpos_i(from,$j = ($j + 1) % $values)) - while nqp::islt_i(++$i,$elems); - } - } - to - } - method !fail-range($got) { - Failure.new(X::OutOfRange.new( - :what($*INDEX // 'Index'), - :$got, - :range("0..{nqp::elems(self)-1}") - )) - } - method !fail-typecheck-element(\action,\i,\got) { - self!fail-typecheck(action ~ "ing element #" ~ i,got); - } - method !fail-typecheck($action,$got) { - Failure.new(X::TypeCheck.new( - operation => $action ~ " to " ~ self.^name, - got => $got, - expected => T, - )) - } -} - -constant blob8 = Blob[uint8]; -constant blob16 = Blob[uint16]; -constant blob32 = Blob[uint32]; -constant blob64 = Blob[uint64]; - -my class utf8 does Blob[uint8] is repr('VMArray') { - multi method decode(utf8:D: $encoding) { - my $enc = Rakudo::Internals.NORMALIZE_ENCODING($encoding); - die "Can not decode a utf-8 buffer as if it were $encoding" - unless $enc eq 'utf8'; - nqp::p6box_s(nqp::decode(self, 'utf8')) - } - method encoding() { 'utf-8' } - multi method Str(utf8:D:) { self.decode } - multi method Stringy(utf8:D:) { self.decode } -} - -my class utf16 does Blob[uint16] is repr('VMArray') { - multi method decode(utf16:D: $encoding = 'utf-16') { - my $enc = Rakudo::Internals.NORMALIZE_ENCODING($encoding); - die "Can not decode a utf-16 buffer as if it were $encoding" - unless $enc eq 'utf16'; - nqp::p6box_s(nqp::decode(self, 'utf16')) - } - method encoding() { 'utf-16' } - multi method Str(utf16:D:) { self.decode } - multi method Stringy(utf16:D:) { self.decode } -} - -my class utf32 does Blob[uint32] is repr('VMArray') { - multi method decode(utf32:D: $encoding = 'utf-32') { - my $enc = Rakudo::Internals.NORMALIZE_ENCODING($encoding); - die "Can not decode a utf-32 buffer as if it were $encoding" - unless $enc eq 'utf32'; - nqp::p6box_s(nqp::decode(self, 'utf32')) - } - method encoding() { 'utf-32' } - multi method Str(utf32:D:) { self.decode } - multi method Stringy(utf32:D:) { self.decode } -} - -my role Buf[::T = uint8] does Blob[T] is repr('VMArray') is array_type(T) { - - multi method WHICH(Buf:D:) { self.Mu::WHICH } - - multi method AT-POS(Buf:D: int \pos) is raw { - nqp::islt_i(pos,0) - ?? Failure.new(X::OutOfRange.new( - :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>)) - !! nqp::atposref_i(self, pos) - } - multi method AT-POS(Buf:D: Int:D \pos) is raw { - my int $pos = nqp::unbox_i(pos); - nqp::islt_i($pos,0) - ?? Failure.new(X::OutOfRange.new( - :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>)) - !! nqp::atposref_i(self,$pos) - } - - multi method ASSIGN-POS(Buf:D: int \pos, Mu \assignee) { - nqp::islt_i(pos,0) - ?? Failure.new(X::OutOfRange.new( - :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>)) - !! nqp::bindpos_i(self,pos,assignee) - } - multi method ASSIGN-POS(Buf:D: Int:D \pos, Mu \assignee) { - my int $pos = nqp::unbox_i(pos); - nqp::islt_i($pos,0) - ?? Failure.new(X::OutOfRange.new( - :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>)) - !! nqp::bindpos_i(self,$pos,assignee) - } - - multi method list(Buf:D:) { - Seq.new(class :: does Rakudo::Iterator::Blobby { - method pull-one() is raw { - nqp::if( - nqp::islt_i(($!i = nqp::add_i($!i,1)),nqp::elems($!blob)), - nqp::atposref_i($!blob,$!i), - IterationEnd - ) - } - }.new(self)).cache - } - - proto method pop(|) { * } - multi method pop(Buf:D:) { - nqp::elems(self) - ?? nqp::pop_i(self) - !! Failure.new(X::Cannot::Empty.new(:action,:what(self.^name))) - } - proto method shift(|) { * } - multi method shift(Buf:D:) { - nqp::elems(self) - ?? nqp::shift_i(self) - !! Failure.new(X::Cannot::Empty.new(:action,:what(self.^name))) - } - - method reallocate(Buf:D: Int:D $elements) { nqp::setelems(self,$elements) } - - my $empty := nqp::list_i; - proto method splice(|) { * } - multi method splice(Buf:D \SELF:) { my $buf = SELF; SELF = Buf.new; $buf } - multi method splice(Buf:D: Int:D $offset, $size = Whatever) { - my int $remove = self!remove($offset,$size); - my $result := $remove - ?? self.subbuf($offset,$remove) # until something smarter - !! nqp::create(self); - nqp::splice(self,$empty,$offset,$remove); - $result - } - multi method splice(Buf:D: Int:D $offset, $size, int $got) { - self!splice-native($offset,$size,$got) - } - multi method splice(Buf:D: Int:D $offset, $size, Int:D $got) { - self!splice-native($offset,$size,$got) - } - multi method splice(Buf:D: Int:D $offset, $size, Mu:D $got) { - self!fail-typecheck('splice',$got) - } - multi method splice(Buf:D: Int:D $offset, $size, Buf:D $buf) { - self!splice-native($offset,$size,$buf) - } - multi method splice(Buf:D: Int:D $offset, $size, int @values) { - self!splice-native($offset,$size,@values) - } - multi method splice(Buf:D: Int:D $offset, $size, @values) { - self!splice-native($offset,$size, - self!push-list("splic",nqp::create(self),@values)) - } - - method !remove(\offset,\size) { - nqp::istype(size,Whatever) - ?? nqp::elems(self) - offset - !! nqp::istype(size,Int) - ?? size - !! size.Int - } - - method !splice-native(Buf:D: Int:D $offset, $size, \x) { - my int $remove = self!remove($offset,$size); - my $result := $remove - ?? self.subbuf($offset,$remove) # until something smarter - !! nqp::create(self); - nqp::splice( - self,nqp::islist(x) ?? x !! nqp::list_i(x),$offset,$remove); - $result - } - - proto method push(|) { * } - multi method push(Buf:D: int $got) { nqp::push_i(self,$got); self } - multi method push(Buf:D: Int:D $got) { nqp::push_i(self,$got); self } - multi method push(Buf:D: Mu:D $got) { self!fail-typecheck('push',$got) } - multi method push(Buf:D: Blob:D $buf) { - nqp::splice(self,$buf,nqp::elems(self),0) - } - multi method push(Buf:D: **@values) { self!pend(@values,'push') } - proto method append(|) { * } - - multi method append(Buf:D: int $got) { nqp::push_i(self,$got); self } - multi method append(Buf:D: Int:D $got) { nqp::push_i(self,$got); self } - multi method append(Buf:D: Mu:D $got) { self!fail-typecheck('append',$got) } - multi method append(Buf:D: Blob:D $buf) { - nqp::splice(self,$buf,nqp::elems(self),0) - } - multi method append(Buf:D: int @values) { - nqp::splice(self,@values,nqp::elems(self),0) - } - multi method append(Buf:D: @values) { self!pend(@values,'append') } - multi method append(Buf:D: *@values) { self!pend(@values,'append') } - proto method unshift(|) { * } - - multi method unshift(Buf:D: int $got) { nqp::unshift_i(self,$got); self } - multi method unshift(Buf:D: Int:D $got) { nqp::unshift_i(self,$got); self } - multi method unshift(Buf:D: Mu:D $got) { self!fail-typecheck('unshift',$got) } - multi method unshift(Buf:D: Blob:D $buf) { nqp::splice(self,$buf,0,0) } - multi method unshift(Buf:D: **@values) { self!pend(@values,'unshift') } - - proto method prepend(|) { * } - multi method prepend(Buf:D: int $got) { nqp::unshift_i(self,$got); self } - multi method prepend(Buf:D: Int:D $got) { nqp::unshift_i(self,$got); self } - multi method prepend(Buf:D: Mu:D $got) { self!fail-typecheck('prepend',$got) } - multi method prepend(Buf:D: Blob:D $buf) { nqp::splice(self,$buf,0,0) } - multi method prepend(Buf:D: int @values) { nqp::splice(self,@values,0,0) } - multi method prepend(Buf:D: @values) { self!pend(@values,'prepend') } - multi method prepend(Buf:D: *@values) { self!pend(@values,'prepend') } - - method !pend(Buf:D: @values, $action) { - @values.is-lazy - ?? Failure.new(X::Cannot::Lazy.new(:$action,:what(self.^name))) - !! $action eq 'push' || $action eq 'append' - ?? self!push-list($action,self,@values) - !! self!unshift-list($action,self,@values) - } - - method subbuf-rw($from = 0, $elems = self.elems - $from) is rw { - my Blob $subbuf = self.subbuf($from, $elems); - Proxy.new( - FETCH => sub ($) { $subbuf }, - STORE => sub ($, Blob:D $new) { - nqp::splice(nqp::decont(self),nqp::decont($new),$from,$elems) - } - ); - } - -} - -constant buf8 = Buf[uint8]; -constant buf16 = Buf[uint16]; -constant buf32 = Buf[uint32]; -constant buf64 = Buf[uint64]; - -proto sub pack(|) {*} -multi sub pack(Str $template, *@items) { - nqp::isnull(nqp::getlexcaller('EXPERIMENTAL-PACK')) and X::Experimental.new( - feature => "the 'pack' function", - use => "pack" - ).throw; - pack($template.comb(/<[a..zA..Z]>[\d+|'*']?/), @items) -} - -multi sub pack(@template, *@items) { - nqp::isnull(nqp::getlexcaller('EXPERIMENTAL-PACK')) and X::Experimental.new( - feature => "the 'pack' function", - use => "pack" - ).throw; - my @bytes; - for @template -> $unit { - my $directive = substr($unit,0,1); - my $amount = substr($unit,1); - - given $directive { - when 'A' { - my $ascii = shift @items // ''; - my $data = $ascii.ords.cache; - if $amount eq '*' { - $amount = $data.elems; - } - if $amount eq '' { - $amount = 1; - } - for (@$data, 0x20 xx *).flat[^$amount] -> $byte { - X::Buf::Pack::NonASCII.new(:char($byte.chr)).throw if $byte > 0x7f; - @bytes.push: $byte; - } - } - when 'a' { - my $data = shift @items // Buf.new; - $data.=encode if nqp::istype($data,Str); - if $amount eq '*' { - $amount = $data.elems; - } - if $amount eq '' { - $amount = 1; - } - for (@$data, 0 xx *).flat[^$amount] -> $byte { - @bytes.push: $byte; - } - } - when 'H' { - my $hexstring = shift @items // ''; - if $hexstring.chars % 2 { - $hexstring ~= '0'; - } - @bytes.append: map { :16($_) }, $hexstring.comb(/../); - } - when 'x' { - if $amount eq '*' { - $amount = 0; - } - elsif $amount eq '' { - $amount = 1; - } - @bytes.append: 0x00 xx $amount; - } - when 'C' { - my $number = shift(@items); - @bytes.push: $number % 0x100; - } - when 'S' | 'v' { - my $number = shift(@items); - @bytes.append: ($number, $number +> 0x08) >>%>> 0x100; - } - when 'L' | 'V' { - my $number = shift(@items); - @bytes.append: ($number, $number +> 0x08, - $number +> 0x10, $number +> 0x18) >>%>> 0x100; - } - when 'n' { - my $number = shift(@items); - @bytes.append: ($number +> 0x08, $number) >>%>> 0x100; - } - when 'N' { - my $number = shift(@items); - @bytes.append: ($number +> 0x18, $number +> 0x10, - $number +> 0x08, $number) >>%>> 0x100; - } - X::Buf::Pack.new(:$directive).throw; - } - } - - return Buf.new(@bytes); -} - -multi sub infix:<~>(Blob:D \a) { a } -multi sub infix:<~>(Blob:D $a, Blob:D $b) { - my $res := nqp::create(nqp::eqaddr($a.WHAT,$b.WHAT) ?? $a !! Buf.^pun); - my $adc := nqp::decont($a); - my $bdc := nqp::decont($b); - my int $alen = nqp::elems($adc); - my int $blen = nqp::elems($bdc); - - nqp::setelems($res, $alen + $blen); - nqp::splice($res, $adc, 0, $alen); - nqp::splice($res, $bdc, $alen, $blen); -} - -multi sub prefix:<~^>(Blob:D \a) { - my $a := nqp::decont(a); - my int $elems = nqp::elems($a); - - my $r := nqp::create($a); - nqp::setelems($a,$elems); - - my int $i = -1; - nqp::bindpos_i($r,$i,nqp::bitneg_i(nqp::atpos_i($a,$i))) - while nqp::islt_i(++$i,$elems); - - $r -} - -multi sub infix:<~&>(Blob:D \a, Blob:D \b) { - my $a := nqp::decont(a); - my $b := nqp::decont(b); - my int $elemsa = nqp::elems($a); - my int $elemsb = nqp::elems($b); - my int $do = $elemsa > $elemsb ?? $elemsb !! $elemsa; - my int $max = $elemsa > $elemsb ?? $elemsa !! $elemsb; - - my $r := nqp::create($a); - nqp::setelems($r,$max); - - my int $i = -1; - nqp::bindpos_i($r,$i, - nqp::bitand_i(nqp::atpos_i($a,$i),nqp::atpos_i($b,$i))) - while nqp::islt_i(++$i,$do); - - --$i; # went one too far - nqp::bindpos_i($r,$i,0) while nqp::islt_i(++$i,$max); - - $r -} - -multi sub infix:<~|>(Blob:D \a, Blob:D \b) { - my $a := nqp::decont(a); - my $b := nqp::decont(b); - my int $elemsa = nqp::elems($a); - my int $elemsb = nqp::elems($b); - my int $do = $elemsa > $elemsb ?? $elemsb !! $elemsa; - my int $max = $elemsa > $elemsb ?? $elemsa !! $elemsb; - my $from := $elemsa > $elemsb ?? $a !! $b; - - my $r := nqp::create($a); - nqp::setelems($r,$max); - - my int $i = -1; - nqp::bindpos_i($r,$i, - nqp::bitor_i(nqp::atpos_i($a,$i),nqp::atpos_i($b,$i))) - while nqp::islt_i(++$i,$do); - - $i = $i - 1; # went one too far - nqp::bindpos_i($r,$i,nqp::atpos_i($from,$i)) - while nqp::islt_i(++$i,$max); - - $r -} - -multi sub infix:<~^>(Blob:D \a, Blob:D \b) { - my $a := nqp::decont(a); - my $b := nqp::decont(b); - my int $elemsa = nqp::elems($a); - my int $elemsb = nqp::elems($b); - my int $do = $elemsa > $elemsb ?? $elemsb !! $elemsa; - my int $max = $elemsa > $elemsb ?? $elemsa !! $elemsb; - my $from := $elemsa > $elemsb ?? $a !! $b; - - my $r := nqp::create($a); - nqp::setelems($r,$max); - - my int $i = -1; - nqp::bindpos_i($r,$i, - nqp::bitxor_i(nqp::atpos_i($a,$i),nqp::atpos_i($b,$i))) - while nqp::islt_i(++$i,$do); - - --$i; # went one too far - nqp::bindpos_i($r,$i,nqp::atpos_i($from,$i)) - while nqp::islt_i(++$i,$max); - - $r -} - -multi sub infix:(Blob:D \a, Blob:D \b) { - nqp::p6bool(nqp::eqaddr(a,b) || (nqp::eqaddr(a.WHAT,b.WHAT) && a.SAME(b))) -} - -multi sub infix:(Blob:D \a, Blob:D \b) { ORDER(a.COMPARE(b)) } -multi sub infix: (Blob:D \a, Blob:D \b) { a =:= b || a.SAME(b) } -multi sub infix: (Blob:D \a, Blob:D \b) { !(a =:= b || a.SAME(b)) } -multi sub infix: (Blob:D \a, Blob:D \b) { a.COMPARE(b) == -1 } -multi sub infix: (Blob:D \a, Blob:D \b) { a.COMPARE(b) == 1 } -multi sub infix: (Blob:D \a, Blob:D \b) { a.COMPARE(b) != 1 } -multi sub infix: (Blob:D \a, Blob:D \b) { a.COMPARE(b) != -1 } - -sub subbuf-rw(Buf:D \b, $from = 0, $elems = b.elems - $from) is rw { - b.subbuf-rw($from, $elems); -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Buf.pm6 rakudo-2018.03/src/core/Buf.pm6 --- rakudo-2018.02.1/src/core/Buf.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Buf.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,862 @@ +my class X::Buf::AsStr { ... } +my class X::Buf::Pack { ... } +my class X::Buf::Pack::NonASCII { ... } +my class X::Cannot::Empty { ... } +my class X::Cannot::Lazy { ... } +my class X::Experimental { ... } + +my role Blob[::T = uint8] does Positional[T] does Stringy is repr('VMArray') is array_type(T) { + X::NYI.new( + feature => "{$?CLASS.^name.comb(/^ \w+ /)}s with native {T.^name}" + ).throw unless nqp::istype(T,Int); + + # other then *8 not supported yet + my int $bpe = try { +#?if jvm + # https://irclog.perlgeek.de/perl6-dev/2017-01-20#i_13961377 + CATCH { default { Nil } } +#?endif + (T.^nativesize / 8).Int + } // 1; + + multi method WHICH(Blob:D:) { + nqp::box_s( + nqp::concat( + nqp::if( + nqp::eqaddr(self.WHAT,Blob), + 'Blob|', + nqp::concat(nqp::unbox_s(self.^name), '|') + ), + nqp::sha1(self.decode("latin-1")) + ), + ValueObjAt + ) + } + + multi method new(Blob:) { nqp::create(self) } + multi method new(Blob: Blob:D $blob) { + nqp::splice(nqp::create(self),$blob,0,0) + } + multi method new(Blob: int @values) { + nqp::splice(nqp::create(self),@values,0,0) + } + multi method new(Blob: @values) { + @values.is-lazy + ?? Failure.new(X::Cannot::Lazy.new(:action,:what(self.^name))) + !! self!push-list("initializ",nqp::create(self),@values) + } + multi method new(Blob: *@values) { self.new(@values) } + + proto method allocate(|) {*} + multi method allocate(Blob:U: Int:D $elements) { + nqp::setelems(nqp::create(self),$elements) + } + multi method allocate(Blob:U: Int:D $elements, int $value) { + my int $elems = $elements; + my $blob := nqp::setelems(nqp::create(self),$elems); + my int $i = -1; + nqp::bindpos_i($blob,$i,$value) while nqp::islt_i(++$i,$elems); + $blob; + } + multi method allocate(Blob:U: Int:D $elements, Int:D \value) { + my int $value = value; + self.allocate($elements,$value) + } + multi method allocate(Blob:U: Int:D $elements, Mu:D $got) { + self!fail-typecheck('allocate',$got) + } + multi method allocate(Blob:U: Int:D $elements, int @values) { + self!spread(nqp::setelems(nqp::create(self),$elements),@values) + } + multi method allocate(Blob:U: Int:D $elements, Blob:D $blob) { + self!spread(nqp::setelems(nqp::create(self),$elements),$blob) + } + multi method allocate(Blob:U: Int:D $elements, @values) { + self!spread(nqp::setelems(nqp::create(self),$elements),Blob.new(@values)) + } + + multi method EXISTS-POS(Blob:D: int \pos) { + nqp::p6bool( + nqp::islt_i(pos,nqp::elems(self)) && nqp::isge_i(pos,0) + ); + } + multi method EXISTS-POS(Blob:D: Int:D \pos) { + nqp::p6bool( + nqp::islt_i(pos,nqp::elems(self)) && nqp::isge_i(pos,0) + ); + } + + multi method AT-POS(Blob:D: int \pos) { + nqp::if( + (nqp::isge_i(pos,nqp::elems(self)) || nqp::islt_i(pos,0)), + self!fail-range(pos), + nqp::atpos_i(self,pos) + ) + } + multi method AT-POS(Blob:D: Int:D \pos) { + nqp::if( + (nqp::isge_i(pos,nqp::elems(self)) || nqp::islt_i(pos,0)), + self!fail-range(pos), + nqp::atpos_i(self,pos) + ) + } + + multi method Bool(Blob:D:) { nqp::p6bool(nqp::elems(self)) } + method Capture(Blob:D:) { self.List.Capture } + + multi method elems(Blob:D:) { nqp::p6box_i(nqp::elems(self)) } + multi method elems(Blob:U: --> 1) { } + method Numeric(Blob:D:) { nqp::p6box_i(nqp::elems(self)) } + method Int(Blob:D:) { nqp::p6box_i(nqp::elems(self)) } + + method bytes(Blob:D:) { nqp::mul_i(nqp::elems(self),$bpe) } + + method chars(Blob:D:) { X::Buf::AsStr.new(method => 'chars').throw } + multi method Str(Blob:D:) { X::Buf::AsStr.new(method => 'Str' ).throw } + multi method Stringy(Blob:D:) { X::Buf::AsStr.new(method => 'Stringy' ).throw } + + proto method decode(|) {*} + multi method decode(Blob:D:) { + nqp::p6box_s(nqp::decode(self, 'utf8')) + } +#?if moar + multi method decode(Blob:D: $encoding, Str :$replacement!, Bool:D :$strict = False) { + nqp::p6box_s( + nqp::decoderepconf(self, + Rakudo::Internals.NORMALIZE_ENCODING($encoding), + $replacement.defined ?? $replacement !! nqp::null_s(), + $strict ?? 0 !! 1)) + } + multi method decode(Blob:D: $encoding, Bool:D :$strict = False) { + nqp::p6box_s( + nqp::decodeconf(self, + Rakudo::Internals.NORMALIZE_ENCODING($encoding), + $strict ?? 0 !! 1)) + } +#?endif +#?if !moar + multi method decode(Blob:D: $encoding, Bool:D :$strict = False) { + nqp::p6box_s( + nqp::decode(self, Rakudo::Internals.NORMALIZE_ENCODING($encoding))) + } + multi method decode(Blob:D: $encoding, Str:D :$replacement!, Bool:D :$strict = False) { + X::NYI.new(:feature).throw + } +#?endif + + multi method list(Blob:D:) { + Seq.new(class :: does Rakudo::Iterator::Blobby { + method pull-one() is raw { + nqp::if( + nqp::islt_i(($!i = nqp::add_i($!i,1)),nqp::elems($!blob)), + nqp::atpos_i($!blob,$!i), + IterationEnd + ) + } + }.new(self)).cache + } + + multi method gist(Blob:D:) { + self.^name ~ ':0x<' ~ self.map( -> \el { + state $i = 0; + ++$i == 101 ?? '...' + !! $i == 102 ?? last() + !! nqp::if(nqp::iseq_i( # el.fmt: '%02x' + nqp::chars(my str $v = nqp::lc(el.base: 16)),1), + nqp::concat('0',$v),$v) + }) ~ '>' + } + multi method perl(Blob:D:) { + self.^name ~ '.new(' ~ self.join(',') ~ ')'; + } + + method subbuf(Blob:D: $from, $length?) { + nqp::stmts( + (my int $elems = nqp::elems(self)), + nqp::if( + $length.DEFINITE && $length < 0, + X::OutOfRange.new( + :what('Len element to subbuf'), :got($length), :range("0..$elems"), + ).fail, + nqp::stmts( + (my int $pos), + (my int $todo), + nqp::if( + nqp::istype($from,Range), + nqp::stmts( + $from.int-bounds($pos, my int $max), + ($todo = nqp::add_i(nqp::sub_i($max, $pos), 1))), + nqp::stmts( + ($pos = nqp::istype($from, Callable) ?? $from($elems) !! $from.Int), + ($todo = $length.DEFINITE ?? $length.Int min $elems - $pos !! $elems - $pos))), + nqp::if( + nqp::islt_i($pos, 0), + X::OutOfRange.new( + :what('From argument to subbuf'), :got($from.gist), :range("0..$elems"), + :comment("use *-{abs $pos} if you want to index relative to the end"), + ).fail, + nqp::if( + nqp::isgt_i($pos, $elems), + X::OutOfRange.new( + :what('From argument to subbuf'), :got($from.gist), :range("0..$elems"), + ).fail, + nqp::if( + nqp::isle_i($todo, 0), + nqp::create(self), # we want zero elements; return empty Blob + nqp::stmts( + (my $subbuf := nqp::create(self)), + nqp::setelems($subbuf, $todo), + (my int $i = -1), + --$pos, + nqp::while( + nqp::islt_i(++$i,$todo), + nqp::bindpos_i($subbuf, $i, nqp::atpos_i(self, ++$pos))), + $subbuf))))))) + } + + method reverse(Blob:D:) { + my int $elems = nqp::elems(self); + my int $last = nqp::sub_i($elems,1); + my $reversed := nqp::setelems(nqp::create(self),$elems); + my int $i = -1; + nqp::while( + nqp::islt_i(($i = nqp::add_i($i,1)),$elems), + nqp::bindpos_i($reversed,nqp::sub_i($last,$i), + nqp::atpos_i(self,$i)) + ); + $reversed + } + + method COMPARE(Blob:D: Blob:D \other) { + my $other := nqp::decont(other); + my int $elems = nqp::elems(self); + if nqp::cmp_i($elems,nqp::elems($other)) -> $diff { + $diff + } + else { + my int $i = -1; + return nqp::cmp_i(nqp::atpos_i(self,$i),nqp::atpos_i($other,$i)) + if nqp::cmp_i(nqp::atpos_i(self,$i),nqp::atpos_i($other,$i)) + while nqp::islt_i(++$i,$elems); + 0 + } + } + + method SAME(Blob:D: Blob:D \other) { + my $other := nqp::decont(other); + my int $elems = nqp::elems(self); + return False unless nqp::iseq_i($elems,nqp::elems($other)); + + my int $i = -1; + return False + unless nqp::iseq_i(nqp::atpos_i(self,$i),nqp::atpos_i($other,$i)) + while nqp::islt_i(++$i,$elems); + + True + } + + method join(Blob:D: $delim = '') { + my int $elems = nqp::elems(self); + my $list := nqp::setelems(nqp::list_s,$elems); + my int $i = -1; + + nqp::bindpos_s($list,$i, + nqp::tostr_I(nqp::p6box_i(nqp::atpos_i(self,$i)))) + while nqp::islt_i(++$i,$elems); + + nqp::join($delim.Str,$list) + } + + proto method unpack(|) {*} + multi method unpack(Blob:D: Str:D $template) { + nqp::isnull(nqp::getlexcaller('EXPERIMENTAL-PACK')) and X::Experimental.new( + feature => "the 'unpack' method", + use => "pack" + ).throw; + self.unpack($template.comb(/<[a..zA..Z]>[\d+|'*']?/)) + } + multi method unpack(Blob:D: @template) { + nqp::isnull(nqp::getlexcaller('EXPERIMENTAL-PACK')) and X::Experimental.new( + feature => "the 'unpack' method", + use => "pack" + ).throw; + my @bytes = self.list; + my @fields; + for @template -> $unit { + my $directive = substr($unit,0,1); + my $amount = substr($unit,1); + my $pa = $amount eq '' ?? 1 !! + $amount eq '*' ?? @bytes.elems !! +$amount; + + given $directive { + when 'a' | 'A' | 'Z' { + @fields.push: @bytes.splice(0, $pa).map(&chr).join; + } + when 'H' { + my str $hexstring = ''; + for ^$pa { + my $byte = shift @bytes; + $hexstring ~= ($byte +> 4).fmt('%x') + ~ ($byte % 16).fmt('%x'); + } + @fields.push($hexstring); + } + when 'x' { + splice @bytes, 0, $pa; + } + when 'C' { + @fields.append: @bytes.splice(0, $pa); + } + when 'S' | 'v' { + for ^$pa { + last if @bytes.elems < 2; + @fields.append: shift(@bytes) + + (shift(@bytes) +< 0x08); + } + } + when 'L' | 'V' { + for ^$pa { + last if @bytes.elems < 4; + @fields.append: shift(@bytes) + + (shift(@bytes) +< 0x08) + + (shift(@bytes) +< 0x10) + + (shift(@bytes) +< 0x18); + } + } + when 'n' { + for ^$pa { + last if @bytes.elems < 2; + @fields.append: (shift(@bytes) +< 0x08) + + shift(@bytes); + } + } + when 'N' { + for ^$pa { + last if @bytes.elems < 4; + @fields.append: (shift(@bytes) +< 0x18) + + (shift(@bytes) +< 0x10) + + (shift(@bytes) +< 0x08) + + shift(@bytes); + } + } + X::Buf::Pack.new(:$directive).throw; + } + } + + return |@fields; + } + + # XXX: the pack.t spectest file seems to require this method + # not sure if it should be changed to list there... + method contents(Blob:D:) { self.list } + + method encoding() { Any } + + method !push-list(\action,\to,\from) { + if nqp::istype(from,List) { + my Mu $from := nqp::getattr(from,List,'$!reified'); + if nqp::defined($from) { + my int $elems = nqp::elems($from); + my int $j = nqp::elems(to); + nqp::setelems(to, $j + $elems); # presize for efficiency + my int $i = -1; + my $got; + nqp::while( + nqp::islt_i(++$i,$elems), + nqp::stmts( + ($got := nqp::atpos($from,$i)), + nqp::istype(nqp::hllize($got),Int) + ?? nqp::bindpos_i(to,$j++,$got) + !! self!fail-typecheck-element(action,$i,$got).throw)) + } + } + else { + my $iter := from.iterator; + my int $i = 0; + my $got; + until ($got := $iter.pull-one) =:= IterationEnd { + nqp::istype($got,Int) + ?? nqp::push_i(to,$got) + !! self!fail-typecheck-element(action,$i,$got).throw; + ++$i; + } + } + to + } + method !unshift-list(\action,\to,\from) { + if nqp::istype(from,List) { + my Mu $from := nqp::getattr(from,List,'$!reified'); + if nqp::defined($from) { + my int $i = nqp::elems($from); + nqp::istype((my $got := nqp::atpos($from,$i)),Int) + ?? nqp::unshift_i(to,$got) + !! self!fail-typecheck-element(action,$i,$got).throw + while nqp::isge_i(--$i,0); + } + to + } + else { + nqp::splice(to,self!push-list(action,nqp::create(self),from),0,0) + } + } + method !spread(\to,\from) { + if nqp::elems(from) -> int $values { # something to init with + my int $elems = nqp::elems(to) - $values; + my int $i = -$values; + nqp::splice(to,from,$i,$values) + while nqp::isle_i($i = $i + $values,$elems); + + if nqp::isgt_i($i,$elems) { # something left to init + --$i; # went one too far + $elems = $elems + $values; + my int $j = -1; + nqp::bindpos_i(to,$i,nqp::atpos_i(from,$j = ($j + 1) % $values)) + while nqp::islt_i(++$i,$elems); + } + } + to + } + method !fail-range($got) { + Failure.new(X::OutOfRange.new( + :what($*INDEX // 'Index'), + :$got, + :range("0..{nqp::elems(self)-1}") + )) + } + method !fail-typecheck-element(\action,\i,\got) { + self!fail-typecheck(action ~ "ing element #" ~ i,got); + } + method !fail-typecheck($action,$got) { + Failure.new(X::TypeCheck.new( + operation => $action ~ " to " ~ self.^name, + got => $got, + expected => T, + )) + } +} + +constant blob8 = Blob[uint8]; +constant blob16 = Blob[uint16]; +constant blob32 = Blob[uint32]; +constant blob64 = Blob[uint64]; + +my class utf8 does Blob[uint8] is repr('VMArray') { + multi method decode(utf8:D: $encoding) { + my $enc = Rakudo::Internals.NORMALIZE_ENCODING($encoding); + die "Can not decode a utf-8 buffer as if it were $encoding" + unless $enc eq 'utf8'; + nqp::p6box_s(nqp::decode(self, 'utf8')) + } + method encoding() { 'utf-8' } + multi method Str(utf8:D:) { self.decode } + multi method Stringy(utf8:D:) { self.decode } +} + +my class utf16 does Blob[uint16] is repr('VMArray') { + multi method decode(utf16:D: $encoding = 'utf-16') { + my $enc = Rakudo::Internals.NORMALIZE_ENCODING($encoding); + die "Can not decode a utf-16 buffer as if it were $encoding" + unless $enc eq 'utf16'; + nqp::p6box_s(nqp::decode(self, 'utf16')) + } + method encoding() { 'utf-16' } + multi method Str(utf16:D:) { self.decode } + multi method Stringy(utf16:D:) { self.decode } +} + +my class utf32 does Blob[uint32] is repr('VMArray') { + multi method decode(utf32:D: $encoding = 'utf-32') { + my $enc = Rakudo::Internals.NORMALIZE_ENCODING($encoding); + die "Can not decode a utf-32 buffer as if it were $encoding" + unless $enc eq 'utf32'; + nqp::p6box_s(nqp::decode(self, 'utf32')) + } + method encoding() { 'utf-32' } + multi method Str(utf32:D:) { self.decode } + multi method Stringy(utf32:D:) { self.decode } +} + +my role Buf[::T = uint8] does Blob[T] is repr('VMArray') is array_type(T) { + + multi method WHICH(Buf:D:) { self.Mu::WHICH } + + multi method AT-POS(Buf:D: int \pos) is raw { + nqp::islt_i(pos,0) + ?? Failure.new(X::OutOfRange.new( + :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>)) + !! nqp::atposref_i(self, pos) + } + multi method AT-POS(Buf:D: Int:D \pos) is raw { + my int $pos = nqp::unbox_i(pos); + nqp::islt_i($pos,0) + ?? Failure.new(X::OutOfRange.new( + :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>)) + !! nqp::atposref_i(self,$pos) + } + + multi method ASSIGN-POS(Buf:D: int \pos, Mu \assignee) { + nqp::islt_i(pos,0) + ?? Failure.new(X::OutOfRange.new( + :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>)) + !! nqp::bindpos_i(self,pos,assignee) + } + multi method ASSIGN-POS(Buf:D: Int:D \pos, Mu \assignee) { + my int $pos = nqp::unbox_i(pos); + nqp::islt_i($pos,0) + ?? Failure.new(X::OutOfRange.new( + :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>)) + !! nqp::bindpos_i(self,$pos,assignee) + } + + multi method list(Buf:D:) { + Seq.new(class :: does Rakudo::Iterator::Blobby { + method pull-one() is raw { + nqp::if( + nqp::islt_i(($!i = nqp::add_i($!i,1)),nqp::elems($!blob)), + nqp::atposref_i($!blob,$!i), + IterationEnd + ) + } + }.new(self)).cache + } + + proto method pop(|) { * } + multi method pop(Buf:D:) { + nqp::elems(self) + ?? nqp::pop_i(self) + !! Failure.new(X::Cannot::Empty.new(:action,:what(self.^name))) + } + proto method shift(|) { * } + multi method shift(Buf:D:) { + nqp::elems(self) + ?? nqp::shift_i(self) + !! Failure.new(X::Cannot::Empty.new(:action,:what(self.^name))) + } + + method reallocate(Buf:D: Int:D $elements) { nqp::setelems(self,$elements) } + + my $empty := nqp::list_i; + proto method splice(|) { * } + multi method splice(Buf:D \SELF:) { my $buf = SELF; SELF = Buf.new; $buf } + multi method splice(Buf:D: Int:D $offset, $size = Whatever) { + my int $remove = self!remove($offset,$size); + my $result := $remove + ?? self.subbuf($offset,$remove) # until something smarter + !! nqp::create(self); + nqp::splice(self,$empty,$offset,$remove); + $result + } + multi method splice(Buf:D: Int:D $offset, $size, int $got) { + self!splice-native($offset,$size,$got) + } + multi method splice(Buf:D: Int:D $offset, $size, Int:D $got) { + self!splice-native($offset,$size,$got) + } + multi method splice(Buf:D: Int:D $offset, $size, Mu:D $got) { + self!fail-typecheck('splice',$got) + } + multi method splice(Buf:D: Int:D $offset, $size, Buf:D $buf) { + self!splice-native($offset,$size,$buf) + } + multi method splice(Buf:D: Int:D $offset, $size, int @values) { + self!splice-native($offset,$size,@values) + } + multi method splice(Buf:D: Int:D $offset, $size, @values) { + self!splice-native($offset,$size, + self!push-list("splic",nqp::create(self),@values)) + } + + method !remove(\offset,\size) { + nqp::istype(size,Whatever) + ?? nqp::elems(self) - offset + !! nqp::istype(size,Int) + ?? size + !! size.Int + } + + method !splice-native(Buf:D: Int:D $offset, $size, \x) { + my int $remove = self!remove($offset,$size); + my $result := $remove + ?? self.subbuf($offset,$remove) # until something smarter + !! nqp::create(self); + nqp::splice( + self,nqp::islist(x) ?? x !! nqp::list_i(x),$offset,$remove); + $result + } + + proto method push(|) { * } + multi method push(Buf:D: int $got) { nqp::push_i(self,$got); self } + multi method push(Buf:D: Int:D $got) { nqp::push_i(self,$got); self } + multi method push(Buf:D: Mu:D $got) { self!fail-typecheck('push',$got) } + multi method push(Buf:D: Blob:D $buf) { + nqp::splice(self,$buf,nqp::elems(self),0) + } + multi method push(Buf:D: **@values) { self!pend(@values,'push') } + proto method append(|) { * } + + multi method append(Buf:D: int $got) { nqp::push_i(self,$got); self } + multi method append(Buf:D: Int:D $got) { nqp::push_i(self,$got); self } + multi method append(Buf:D: Mu:D $got) { self!fail-typecheck('append',$got) } + multi method append(Buf:D: Blob:D $buf) { + nqp::splice(self,$buf,nqp::elems(self),0) + } + multi method append(Buf:D: int @values) { + nqp::splice(self,@values,nqp::elems(self),0) + } + multi method append(Buf:D: @values) { self!pend(@values,'append') } + multi method append(Buf:D: *@values) { self!pend(@values,'append') } + proto method unshift(|) { * } + + multi method unshift(Buf:D: int $got) { nqp::unshift_i(self,$got); self } + multi method unshift(Buf:D: Int:D $got) { nqp::unshift_i(self,$got); self } + multi method unshift(Buf:D: Mu:D $got) { self!fail-typecheck('unshift',$got) } + multi method unshift(Buf:D: Blob:D $buf) { nqp::splice(self,$buf,0,0) } + multi method unshift(Buf:D: **@values) { self!pend(@values,'unshift') } + + proto method prepend(|) { * } + multi method prepend(Buf:D: int $got) { nqp::unshift_i(self,$got); self } + multi method prepend(Buf:D: Int:D $got) { nqp::unshift_i(self,$got); self } + multi method prepend(Buf:D: Mu:D $got) { self!fail-typecheck('prepend',$got) } + multi method prepend(Buf:D: Blob:D $buf) { nqp::splice(self,$buf,0,0) } + multi method prepend(Buf:D: int @values) { nqp::splice(self,@values,0,0) } + multi method prepend(Buf:D: @values) { self!pend(@values,'prepend') } + multi method prepend(Buf:D: *@values) { self!pend(@values,'prepend') } + + method !pend(Buf:D: @values, $action) { + @values.is-lazy + ?? Failure.new(X::Cannot::Lazy.new(:$action,:what(self.^name))) + !! $action eq 'push' || $action eq 'append' + ?? self!push-list($action,self,@values) + !! self!unshift-list($action,self,@values) + } + + method subbuf-rw($from = 0, $elems = self.elems - $from) is rw { + my Blob $subbuf = self.subbuf($from, $elems); + Proxy.new( + FETCH => sub ($) { $subbuf }, + STORE => sub ($, Blob:D $new) { + nqp::splice(nqp::decont(self),nqp::decont($new),$from,$elems) + } + ); + } + +} + +constant buf8 = Buf[uint8]; +constant buf16 = Buf[uint16]; +constant buf32 = Buf[uint32]; +constant buf64 = Buf[uint64]; + +proto sub pack(|) {*} +multi sub pack(Str $template, *@items) { + nqp::isnull(nqp::getlexcaller('EXPERIMENTAL-PACK')) and X::Experimental.new( + feature => "the 'pack' function", + use => "pack" + ).throw; + pack($template.comb(/<[a..zA..Z]>[\d+|'*']?/), @items) +} + +multi sub pack(@template, *@items) { + nqp::isnull(nqp::getlexcaller('EXPERIMENTAL-PACK')) and X::Experimental.new( + feature => "the 'pack' function", + use => "pack" + ).throw; + my @bytes; + for @template -> $unit { + my $directive = substr($unit,0,1); + my $amount = substr($unit,1); + + given $directive { + when 'A' { + my $ascii = shift @items // ''; + my $data = $ascii.ords.cache; + if $amount eq '*' { + $amount = $data.elems; + } + if $amount eq '' { + $amount = 1; + } + for (@$data, 0x20 xx *).flat[^$amount] -> $byte { + X::Buf::Pack::NonASCII.new(:char($byte.chr)).throw if $byte > 0x7f; + @bytes.push: $byte; + } + } + when 'a' { + my $data = shift @items // Buf.new; + $data.=encode if nqp::istype($data,Str); + if $amount eq '*' { + $amount = $data.elems; + } + if $amount eq '' { + $amount = 1; + } + for (@$data, 0 xx *).flat[^$amount] -> $byte { + @bytes.push: $byte; + } + } + when 'H' { + my $hexstring = shift @items // ''; + if $hexstring.chars % 2 { + $hexstring ~= '0'; + } + @bytes.append: map { :16($_) }, $hexstring.comb(/../); + } + when 'x' { + if $amount eq '*' { + $amount = 0; + } + elsif $amount eq '' { + $amount = 1; + } + @bytes.append: 0x00 xx $amount; + } + when 'C' { + my $number = shift(@items); + @bytes.push: $number % 0x100; + } + when 'S' | 'v' { + my $number = shift(@items); + @bytes.append: ($number, $number +> 0x08) >>%>> 0x100; + } + when 'L' | 'V' { + my $number = shift(@items); + @bytes.append: ($number, $number +> 0x08, + $number +> 0x10, $number +> 0x18) >>%>> 0x100; + } + when 'n' { + my $number = shift(@items); + @bytes.append: ($number +> 0x08, $number) >>%>> 0x100; + } + when 'N' { + my $number = shift(@items); + @bytes.append: ($number +> 0x18, $number +> 0x10, + $number +> 0x08, $number) >>%>> 0x100; + } + X::Buf::Pack.new(:$directive).throw; + } + } + + return Buf.new(@bytes); +} + +multi sub infix:<~>(Blob:D \a) { a } +multi sub infix:<~>(Blob:D $a, Blob:D $b) { + my $res := nqp::create(nqp::eqaddr($a.WHAT,$b.WHAT) ?? $a !! Buf.^pun); + my $adc := nqp::decont($a); + my $bdc := nqp::decont($b); + my int $alen = nqp::elems($adc); + my int $blen = nqp::elems($bdc); + + nqp::setelems($res, $alen + $blen); + nqp::splice($res, $adc, 0, $alen); + nqp::splice($res, $bdc, $alen, $blen); +} + +multi sub prefix:<~^>(Blob:D \a) { + my $a := nqp::decont(a); + my int $elems = nqp::elems($a); + + my $r := nqp::create($a); + nqp::setelems($a,$elems); + + my int $i = -1; + nqp::bindpos_i($r,$i,nqp::bitneg_i(nqp::atpos_i($a,$i))) + while nqp::islt_i(++$i,$elems); + + $r +} + +multi sub infix:<~&>(Blob:D \a, Blob:D \b) { + my $a := nqp::decont(a); + my $b := nqp::decont(b); + my int $elemsa = nqp::elems($a); + my int $elemsb = nqp::elems($b); + my int $do = $elemsa > $elemsb ?? $elemsb !! $elemsa; + my int $max = $elemsa > $elemsb ?? $elemsa !! $elemsb; + + my $r := nqp::create($a); + nqp::setelems($r,$max); + + my int $i = -1; + nqp::bindpos_i($r,$i, + nqp::bitand_i(nqp::atpos_i($a,$i),nqp::atpos_i($b,$i))) + while nqp::islt_i(++$i,$do); + + --$i; # went one too far + nqp::bindpos_i($r,$i,0) while nqp::islt_i(++$i,$max); + + $r +} + +multi sub infix:<~|>(Blob:D \a, Blob:D \b) { + my $a := nqp::decont(a); + my $b := nqp::decont(b); + my int $elemsa = nqp::elems($a); + my int $elemsb = nqp::elems($b); + my int $do = $elemsa > $elemsb ?? $elemsb !! $elemsa; + my int $max = $elemsa > $elemsb ?? $elemsa !! $elemsb; + my $from := $elemsa > $elemsb ?? $a !! $b; + + my $r := nqp::create($a); + nqp::setelems($r,$max); + + my int $i = -1; + nqp::bindpos_i($r,$i, + nqp::bitor_i(nqp::atpos_i($a,$i),nqp::atpos_i($b,$i))) + while nqp::islt_i(++$i,$do); + + $i = $i - 1; # went one too far + nqp::bindpos_i($r,$i,nqp::atpos_i($from,$i)) + while nqp::islt_i(++$i,$max); + + $r +} + +multi sub infix:<~^>(Blob:D \a, Blob:D \b) { + my $a := nqp::decont(a); + my $b := nqp::decont(b); + my int $elemsa = nqp::elems($a); + my int $elemsb = nqp::elems($b); + my int $do = $elemsa > $elemsb ?? $elemsb !! $elemsa; + my int $max = $elemsa > $elemsb ?? $elemsa !! $elemsb; + my $from := $elemsa > $elemsb ?? $a !! $b; + + my $r := nqp::create($a); + nqp::setelems($r,$max); + + my int $i = -1; + nqp::bindpos_i($r,$i, + nqp::bitxor_i(nqp::atpos_i($a,$i),nqp::atpos_i($b,$i))) + while nqp::islt_i(++$i,$do); + + --$i; # went one too far + nqp::bindpos_i($r,$i,nqp::atpos_i($from,$i)) + while nqp::islt_i(++$i,$max); + + $r +} + +multi sub infix:(Blob:D \a, Blob:D \b) { + nqp::p6bool(nqp::eqaddr(a,b) || (nqp::eqaddr(a.WHAT,b.WHAT) && a.SAME(b))) +} + +multi sub infix:(Blob:D \a, Blob:D \b) { ORDER(a.COMPARE(b)) } +multi sub infix: (Blob:D \a, Blob:D \b) { a =:= b || a.SAME(b) } +multi sub infix: (Blob:D \a, Blob:D \b) { !(a =:= b || a.SAME(b)) } +multi sub infix: (Blob:D \a, Blob:D \b) { a.COMPARE(b) == -1 } +multi sub infix: (Blob:D \a, Blob:D \b) { a.COMPARE(b) == 1 } +multi sub infix: (Blob:D \a, Blob:D \b) { a.COMPARE(b) != 1 } +multi sub infix: (Blob:D \a, Blob:D \b) { a.COMPARE(b) != -1 } + +proto sub subbuf-rw(|) {*} +multi sub subbuf-rw(Buf:D \b) is rw { + b.subbuf-rw(0, b.elems); +} +multi sub subbuf-rw(Buf:D \b, Int() $from) is rw { + b.subbuf-rw($from, b.elems - $from) +} +multi sub subbuf-rw(Buf:D \b, $from, $elems) is rw { + b.subbuf-rw($from, $elems) +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Callable.pm rakudo-2018.03/src/core/Callable.pm --- rakudo-2018.02.1/src/core/Callable.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Callable.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ -my class X::Cannot::Capture { ... } - -my role Callable[::T = Mu] { - method of() { T } - method returns() { T } - method Capture() { die X::Cannot::Capture.new: :what(self) } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Callable.pm6 rakudo-2018.03/src/core/Callable.pm6 --- rakudo-2018.02.1/src/core/Callable.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Callable.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,9 @@ +my class X::Cannot::Capture { ... } + +my role Callable[::T = Mu] { + method of() { T } + method returns() { T } + method Capture() { die X::Cannot::Capture.new: :what(self) } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CallFrame.pm rakudo-2018.03/src/core/CallFrame.pm --- rakudo-2018.02.1/src/core/CallFrame.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CallFrame.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -my class CallFrame { - has $.annotations; - has $.my; - - method SET-SELF(\level, Mu \ctx is raw, Mu \bt is raw) { - nqp::stmts( - (my int $i = nqp::add_i(level,1)), - ($!annotations := nqp::atkey( - nqp::atpos(nqp::getattr(bt,List,'$!reified'),$i), - 'annotations' - )), - (my $ctx := ctx), - nqp::while( - nqp::isgt_i(($i = nqp::sub_i($i,1)),0), - nqp::ifnull( - ($ctx := nqp::ctxcaller($ctx)), - fail "No callframe at level {level}" - ) - ), - ($!my := - nqp::p6bindattrinvres(nqp::create(Stash),Map,'$!storage',$ctx)), - self - ) - } - - only method new(CallFrame: Int:D $level = 0) { # MUST BE AN only - nqp::create(CallFrame).SET-SELF( # wrt to backtrace levels - $level, - nqp::ctxcaller(nqp::ctx), - nqp::backtrace(nqp::handle(nqp::die(''),'CATCH',nqp::exception)) - ) - } - - method line() { nqp::atkey($!annotations,'line') } - method file() { nqp::atkey($!annotations,'file') } - method code() { - my \vm-code = nqp::ctxcode(nqp::getattr($!my,Map,'$!storage')); - nqp::isnull(vm-code) ?? Nil !! nqp::getcodeobj(vm-code) - } - method callframe(Int:D $?) { - X::NYI.new(feature => 'Callframe.callframe').throw; - } - - multi method gist(CallFrame:D:) { - nqp::atkey($!annotations,'file') - ~ ' at line ' - ~ nqp::atkey($!annotations,'line') - } - - method annotations() { - nqp::p6bindattrinvres(nqp::create(Map),Map,'$!storage',$!annotations) - } -} - -only sub callframe(Int:D $level = 0) { # MUST BE an only wrt to backtrace levels - nqp::create(CallFrame).SET-SELF( - $level, - nqp::ctxcaller(nqp::ctx), - nqp::backtrace(nqp::handle(nqp::die(''),'CATCH',nqp::exception)) - ) -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CallFrame.pm6 rakudo-2018.03/src/core/CallFrame.pm6 --- rakudo-2018.02.1/src/core/CallFrame.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CallFrame.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,63 @@ +my class CallFrame { + has $.annotations; + has $.my; + + method SET-SELF(\level, Mu \ctx is raw, Mu \bt is raw) { + nqp::stmts( + (my int $i = nqp::add_i(level,1)), + ($!annotations := nqp::atkey( + nqp::atpos(nqp::getattr(bt,List,'$!reified'),$i), + 'annotations' + )), + (my $ctx := ctx), + nqp::while( + nqp::isgt_i(($i = nqp::sub_i($i,1)),0), + nqp::ifnull( + ($ctx := nqp::ctxcaller($ctx)), + fail "No callframe at level {level}" + ) + ), + ($!my := + nqp::p6bindattrinvres(nqp::create(Stash),Map,'$!storage',$ctx)), + self + ) + } + + only method new(CallFrame: Int:D $level = 0) { # MUST BE AN only + nqp::create(CallFrame).SET-SELF( # wrt to backtrace levels + $level, + nqp::ctxcaller(nqp::ctx), + nqp::backtrace(nqp::handle(nqp::die(''),'CATCH',nqp::exception)) + ) + } + + method line() { nqp::atkey($!annotations,'line') } + method file() { nqp::atkey($!annotations,'file') } + method code() { + my \vm-code = nqp::ctxcode(nqp::getattr($!my,Map,'$!storage')); + nqp::isnull(vm-code) ?? Nil !! nqp::getcodeobj(vm-code) + } + method callframe(Int:D $?) { + X::NYI.new(feature => 'Callframe.callframe').throw; + } + + multi method gist(CallFrame:D:) { + nqp::atkey($!annotations,'file') + ~ ' at line ' + ~ nqp::atkey($!annotations,'line') + } + + method annotations() { + nqp::p6bindattrinvres(nqp::create(Map),Map,'$!storage',$!annotations) + } +} + +only sub callframe(Int:D $level = 0) { # MUST BE an only wrt to backtrace levels + nqp::create(CallFrame).SET-SELF( + $level, + nqp::ctxcaller(nqp::ctx), + nqp::backtrace(nqp::handle(nqp::die(''),'CATCH',nqp::exception)) + ) +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Cancellation.pm rakudo-2018.03/src/core/Cancellation.pm --- rakudo-2018.02.1/src/core/Cancellation.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Cancellation.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -my class Cancellation { - has $.cancelled; - has $!lock; - has @!async_handles; - - submethod BUILD(:@!async_handles --> Nil) { - $!cancelled = False; - $!lock = Lock.new; - } - - method cancel() { - $!lock.protect({ - unless $!cancelled { - for @!async_handles { - nqp::cancel(nqp::decont($_)); - } - $!cancelled = True; - } - }) - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Cancellation.pm6 rakudo-2018.03/src/core/Cancellation.pm6 --- rakudo-2018.02.1/src/core/Cancellation.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Cancellation.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,23 @@ +my class Cancellation { + has $.cancelled; + has $!lock; + has @!async_handles; + + submethod BUILD(:@!async_handles --> Nil) { + $!cancelled = False; + $!lock = Lock.new; + } + + method cancel() { + $!lock.protect({ + unless $!cancelled { + for @!async_handles { + nqp::cancel(nqp::decont($_)); + } + $!cancelled = True; + } + }) + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Capture.pm rakudo-2018.03/src/core/Capture.pm --- rakudo-2018.02.1/src/core/Capture.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Capture.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,157 +0,0 @@ -my class Capture { # declared in BOOTSTRAP - # class Capture is Any - # has @!list; # positional parameters - # has %!hash; # named parameters - - method from-args(|c) { c } - - submethod BUILD(:@list, :%hash --> Nil) { - @list.elems; # force reification of all - nqp::bindattr(self, Capture, '@!list', - nqp::getattr(nqp::decont(@list.list), List, '$!reified') - ); - nqp::bindattr(self,Capture,'%!hash', - nqp::getattr(nqp::decont(%hash),Map,'$!storage')) - if nqp::attrinited(nqp::decont(%hash),Map,'$!storage') - } - - multi method WHICH (Capture:D:) { - my $WHICH = nqp::istype(self.WHAT,Capture) ?? 'Capture' !! self.^name; - if !nqp::isnull(@!list) && @!list { - $WHICH ~= '|'; - for nqp::hllize(@!list) -> \elem { - $WHICH ~= ( '(' ~ elem.VAR.WHICH ~ ')' ) - } - } - if !nqp::isnull(%!hash) && %!hash { - $WHICH ~= '|'; - $WHICH ~= ( $_ ~ '(' ~ nqp::atkey(%!hash, nqp::unbox_s($_)).WHICH ~ ')' ) - for nqp::hllize(%!hash).keys.sort; - } - $WHICH; - } - - multi method AT-KEY(Capture:D: Str:D \key) is raw { - nqp::ifnull(nqp::atkey(%!hash,nqp::unbox_s(key)), Nil) - } - multi method AT-KEY(Capture:D: \key) is raw { - nqp::ifnull(nqp::atkey(%!hash,nqp::unbox_s(key.Str)), Nil) - } - - multi method AT-POS(Capture:D: int \pos) is raw { - nqp::islt_i(pos,0) - ?? Failure.new(X::OutOfRange.new( - :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>)) - !! nqp::ifnull(nqp::atpos(@!list,pos),Nil) - } - multi method AT-POS(Capture:D: Int:D \pos) is raw { - my int $pos = nqp::unbox_i(pos); - nqp::islt_i($pos,0) - ?? Failure.new(X::OutOfRange.new( - :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>)) - !! nqp::ifnull(nqp::atpos(@!list,$pos),Nil) - } - - method hash(Capture:D:) { - nqp::if( - (nqp::defined(%!hash) && nqp::elems(%!hash)), - nqp::p6bindattrinvres(nqp::create(Map),Map,'$!storage',%!hash), - nqp::create(Map) - ) - } - - multi method EXISTS-KEY(Capture:D: Str:D \key ) { - nqp::p6bool(nqp::existskey(%!hash, nqp::unbox_s(key))); - } - multi method EXISTS-KEY(Capture:D: \key ) { - nqp::p6bool(nqp::existskey(%!hash, nqp::unbox_s(key.Str))); - } - - method list(Capture:D:) { - nqp::if( - (nqp::defined(@!list) && nqp::elems(@!list)), - nqp::p6bindattrinvres(nqp::create(List),List,'$!reified',@!list), - nqp::create(List) - ) - } - - method elems(Capture:D:) { - nqp::isnull(@!list) ?? 0 !! nqp::p6box_i(nqp::elems(@!list)) - } - - multi method Str(Capture:D:) { - my Mu $str := nqp::list_s(); - if @!list { - my Mu $iter := nqp::iterator(@!list); - nqp::push_s($str, nqp::unbox_s(nqp::shift($iter).Str)) while $iter; - } - if %!hash { - my Mu $iter := nqp::iterator(%!hash); - while $iter { - my $kv := nqp::shift($iter); - nqp::push_s($str, nqp::unbox_s((nqp::p6box_s(nqp::iterkey_s($kv)) => nqp::iterval($kv).Str).Str)); - } - } - nqp::p6box_s(nqp::join(' ', $str)) - } - multi method gist(Capture:D:) { self.Capture::perl } - multi method perl(Capture:D:) { - my %hash := self.Capture::hash; - if self.^name eq 'Capture' { - "\\({ - join ', ', - ((nqp::atpos(@!list, $_).perl for ^nqp::elems(@!list)) if @!list), - %hash.sort.map( *.perl ) - })"; - } else { - self.^name - ~ '.new(' - ~ ( 'list => (' ~ (nqp::atpos(@!list, $_).perl for ^nqp::elems(@!list)).join(', ') ~ ',)' if @!list) - ~ (', ' if +@!list and +%hash) - ~ ( 'hash => {' ~ %hash.sort.map( *.perl ).join(', ') ~ '}' if +%hash) - ~ ')'; - } - } - multi method Bool(Capture:D:) { - nqp::p6bool( - nqp::elems(@!list) || nqp::elems(%!hash) - ) - } - - method Capture(Capture:D:) { - self - } - - multi method Numeric(Capture:D:) { - self.Capture::elems - } - - method FLATTENABLE_LIST() { @!list ?? @!list !! nqp::list() } - method FLATTENABLE_HASH() { %!hash ?? %!hash !! nqp::hash() } - - multi method keys(Capture:D:) { - (self.Capture::list.keys, self.Capture::hash.keys).flat; - } - multi method kv(Capture:D:) { - (self.Capture::list.kv, self.Capture::hash.kv).flat; - } - multi method values(Capture:D:) { - (self.Capture::list.values, self.Capture::hash.values).flat; - } - multi method pairs(Capture:D:) { - (self.Capture::list.pairs, self.Capture::hash.pairs).flat; - } - multi method antipairs(Capture:D:) { - (self.Capture::list.antipairs, self.Capture::hash.antipairs).flat; - } -} - -multi sub infix:(Capture:D \a, Capture:D \b) { - nqp::p6bool( - nqp::eqaddr(a,b) - || (nqp::eqaddr(a.WHAT,b.WHAT) - && a.Capture::list eqv b.Capture::list && a.Capture::hash eqv b.Capture::hash) - ) -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Capture.pm6 rakudo-2018.03/src/core/Capture.pm6 --- rakudo-2018.02.1/src/core/Capture.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Capture.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,157 @@ +my class Capture { # declared in BOOTSTRAP + # class Capture is Any + # has @!list; # positional parameters + # has %!hash; # named parameters + + method from-args(|c) { c } + + submethod BUILD(:@list, :%hash --> Nil) { + @list.elems; # force reification of all + nqp::bindattr(self, Capture, '@!list', + nqp::getattr(nqp::decont(@list.list), List, '$!reified') + ); + nqp::bindattr(self,Capture,'%!hash', + nqp::getattr(nqp::decont(%hash),Map,'$!storage')) + if nqp::attrinited(nqp::decont(%hash),Map,'$!storage') + } + + multi method WHICH (Capture:D:) { + my $WHICH = nqp::istype(self.WHAT,Capture) ?? 'Capture' !! self.^name; + if !nqp::isnull(@!list) && @!list { + $WHICH ~= '|'; + for nqp::hllize(@!list) -> \elem { + $WHICH ~= ( '(' ~ elem.VAR.WHICH ~ ')' ) + } + } + if !nqp::isnull(%!hash) && %!hash { + $WHICH ~= '|'; + $WHICH ~= ( $_ ~ '(' ~ nqp::atkey(%!hash, nqp::unbox_s($_)).WHICH ~ ')' ) + for nqp::hllize(%!hash).keys.sort; + } + $WHICH; + } + + multi method AT-KEY(Capture:D: Str:D \key) is raw { + nqp::ifnull(nqp::atkey(%!hash,nqp::unbox_s(key)), Nil) + } + multi method AT-KEY(Capture:D: \key) is raw { + nqp::ifnull(nqp::atkey(%!hash,nqp::unbox_s(key.Str)), Nil) + } + + multi method AT-POS(Capture:D: int \pos) is raw { + nqp::islt_i(pos,0) + ?? Failure.new(X::OutOfRange.new( + :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>)) + !! nqp::ifnull(nqp::atpos(@!list,pos),Nil) + } + multi method AT-POS(Capture:D: Int:D \pos) is raw { + my int $pos = nqp::unbox_i(pos); + nqp::islt_i($pos,0) + ?? Failure.new(X::OutOfRange.new( + :what($*INDEX // 'Index'),:got(pos),:range<0..^Inf>)) + !! nqp::ifnull(nqp::atpos(@!list,$pos),Nil) + } + + method hash(Capture:D:) { + nqp::if( + (nqp::defined(%!hash) && nqp::elems(%!hash)), + nqp::p6bindattrinvres(nqp::create(Map),Map,'$!storage',%!hash), + nqp::create(Map) + ) + } + + multi method EXISTS-KEY(Capture:D: Str:D \key ) { + nqp::p6bool(nqp::existskey(%!hash, nqp::unbox_s(key))); + } + multi method EXISTS-KEY(Capture:D: \key ) { + nqp::p6bool(nqp::existskey(%!hash, nqp::unbox_s(key.Str))); + } + + method list(Capture:D:) { + nqp::if( + (nqp::defined(@!list) && nqp::elems(@!list)), + nqp::p6bindattrinvres(nqp::create(List),List,'$!reified',@!list), + nqp::create(List) + ) + } + + method elems(Capture:D:) { + nqp::isnull(@!list) ?? 0 !! nqp::p6box_i(nqp::elems(@!list)) + } + + multi method Str(Capture:D:) { + my Mu $str := nqp::list_s(); + if @!list { + my Mu $iter := nqp::iterator(@!list); + nqp::push_s($str, nqp::unbox_s(nqp::shift($iter).Str)) while $iter; + } + if %!hash { + my Mu $iter := nqp::iterator(%!hash); + while $iter { + my $kv := nqp::shift($iter); + nqp::push_s($str, nqp::unbox_s((nqp::p6box_s(nqp::iterkey_s($kv)) => nqp::iterval($kv).Str).Str)); + } + } + nqp::p6box_s(nqp::join(' ', $str)) + } + multi method gist(Capture:D:) { self.Capture::perl } + multi method perl(Capture:D:) { + my %hash := self.Capture::hash; + if self.^name eq 'Capture' { + "\\({ + join ', ', + ((nqp::atpos(@!list, $_).perl for ^nqp::elems(@!list)) if @!list), + %hash.sort.map( *.perl ) + })"; + } else { + self.^name + ~ '.new(' + ~ ( 'list => (' ~ (nqp::atpos(@!list, $_).perl for ^nqp::elems(@!list)).join(', ') ~ ',)' if @!list) + ~ (', ' if +@!list and +%hash) + ~ ( 'hash => {' ~ %hash.sort.map( *.perl ).join(', ') ~ '}' if +%hash) + ~ ')'; + } + } + multi method Bool(Capture:D:) { + nqp::p6bool( + nqp::elems(@!list) || nqp::elems(%!hash) + ) + } + + method Capture(Capture:D:) { + self + } + + multi method Numeric(Capture:D:) { + self.Capture::elems + } + + method FLATTENABLE_LIST() { @!list ?? @!list !! nqp::list() } + method FLATTENABLE_HASH() { %!hash ?? %!hash !! nqp::hash() } + + multi method keys(Capture:D:) { + (self.Capture::list.keys, self.Capture::hash.keys).flat; + } + multi method kv(Capture:D:) { + (self.Capture::list.kv, self.Capture::hash.kv).flat; + } + multi method values(Capture:D:) { + (self.Capture::list.values, self.Capture::hash.values).flat; + } + multi method pairs(Capture:D:) { + (self.Capture::list.pairs, self.Capture::hash.pairs).flat; + } + multi method antipairs(Capture:D:) { + (self.Capture::list.antipairs, self.Capture::hash.antipairs).flat; + } +} + +multi sub infix:(Capture:D \a, Capture:D \b) { + nqp::p6bool( + nqp::eqaddr(a,b) + || (nqp::eqaddr(a.WHAT,b.WHAT) + && a.Capture::list eqv b.Capture::list && a.Capture::hash eqv b.Capture::hash) + ) +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Channel.pm rakudo-2018.03/src/core/Channel.pm --- rakudo-2018.02.1/src/core/Channel.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Channel.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,264 +0,0 @@ -# A channel provides a thread-safe way to send a series of values from some -# producer(s) to some consumer(s). -my class X::Channel::SendOnClosed is Exception { - has $.channel; - method message() { "Cannot send a message on a closed channel" } -} -my class X::Channel::ReceiveOnClosed is Exception { - has $.channel; - method message() { "Cannot receive a message on a closed channel" } -} -my class Channel does Awaitable { - # The queue of events moving through the channel. - my class Queue is repr('ConcBlockingQueue') { } - has $!queue; - - # Promise that is triggered when all values are received, or an error is - # received and the channel is thus closed. - has $!closed_promise; - - # Closed promise's vow. - has $!closed_promise_vow; - - # Flag for if the channel is closed to senders. - has $!closed; - - # We use a Supplier to send async notifications that there may be a new - # message to read from the channel (there may be many things competing - # over them). - has $!async-notify; - - # Magical objects for various ways a channel can end. - my class CHANNEL_CLOSE { } - my class CHANNEL_FAIL { has $.error } - - submethod BUILD(--> Nil) { - $!queue := nqp::create(Queue); - $!closed_promise = Promise.new; - $!closed_promise_vow = $!closed_promise.vow; - $!async-notify = Supplier.new; - } - - method send(Channel:D: \item) { - X::Channel::SendOnClosed.new(channel => self).throw if $!closed; - nqp::push($!queue, nqp::decont(item)); - $!async-notify.emit(True); - Nil - } - - method !receive(Channel:D: $fail-on-close) { - my \msg := nqp::shift($!queue); - if nqp::istype(msg, CHANNEL_CLOSE) { - nqp::push($!queue, msg); # make sure other readers see it - $!closed_promise_vow.keep(Nil); - X::Channel::ReceiveOnClosed.new(channel => self).throw - if $fail-on-close; - Nil - } - elsif nqp::istype(msg, CHANNEL_FAIL) { - nqp::push($!queue, msg); # make sure other readers see it - $!closed_promise_vow.break(msg.error); - msg.error.rethrow; - } - else { - msg - } - } - - method receive(Channel:D:) { self!receive(1) } - method receive-nil-on-close(Channel:D:) { self!receive(0) } - - method poll(Channel:D:) { - my \msg := nqp::queuepoll($!queue); - if nqp::isnull(msg) { - Nil - } else { - if nqp::istype(msg, CHANNEL_CLOSE) { - $!closed_promise_vow.keep(Nil); - Nil - } - elsif nqp::istype(msg, CHANNEL_FAIL) { - $!closed_promise_vow.break(msg.error); - Nil - } - else { - msg - } - } - } - - method !peek(Channel:D:) { - my \msg := nqp::atpos($!queue, 0); - if nqp::isnull(msg) { - Nil - } else { - if nqp::istype(msg, CHANNEL_CLOSE) { - $!closed_promise_vow.keep(Nil); - Nil - } - elsif nqp::istype(msg, CHANNEL_FAIL) { - $!closed_promise_vow.break(msg.error); - Nil - } - else { - msg - } - } - } - - method Capture(Channel:D:) { self.List.Capture } - multi method Supply(Channel:D:) { - supply { - # Tap the async notification for new values supply. - whenever $!async-notify.unsanitized-supply.schedule-on($*SCHEDULER) { - my Mu \got = self.poll; - if nqp::eqaddr(got, Nil) { - if $!closed_promise { - $!closed_promise.status == Kept - ?? done() - !! die $!closed_promise.cause - } - } - else { - emit got; - } - } - - # Grab anything that's in the channel and emit it. Note that - # it's important to do this after tapping the supply, or a - # value sent between us draining it and doing the tap would - # not result in a notification, and so we'd not emit it on - # the supply. This lost event can then cause a deadlock. - loop { - my Mu \got = self.poll; - last if nqp::eqaddr(got, Nil); - emit got; - } - self!peek(); - if $!closed_promise { - $!closed_promise.status == Kept - ?? done() - !! die $!closed_promise.cause - } - } - } - - method iterator(Channel:D:) { - class :: does Iterator { - has $!channel; - method !SET-SELF($!channel) { self } - method new(\c) { nqp::create(self)!SET-SELF(c) } - method pull-one() { - my Mu \got = $!channel.receive-nil-on-close; - nqp::eqaddr(got, Nil) ?? IterationEnd !! got - } - }.new(self) - } - - method list(Channel:D:) { self.Seq.list } - - my class ChannelAwaitableHandle does Awaitable::Handle { - has $!channel; - has $!closed_promise; - has $!async-notify; - - method not-ready(Channel:D $channel, Promise:D $closed_promise, Supplier:D $async-notify) { - nqp::create(self)!not-ready($channel, $closed_promise, $async-notify) - } - method !not-ready($channel, $closed_promise, $async-notify) { - $!already = False; - $!channel := $channel; - $!closed_promise := $closed_promise; - $!async-notify := $async-notify; - self - } - - method subscribe-awaiter(&subscriber --> Nil) { - # Need some care here to avoid a race. We must tap the notification - # supply first, and then do an immediate poll after it, just to be - # sure we won't miss notifications between the two. Also, we need - # to take some care that we never call subscriber twice. - my $notified := False; - my $l := Lock.new; - my $t; - $l.protect: { - # Lock ensures $t will be assigned before we run the logic - # inside of poll-now, which relies on being able to do - # $t.close. - $t := $!async-notify.unsanitized-supply.tap: &poll-now; - } - poll-now(); - - sub poll-now($discard?) { - $l.protect: { - unless $notified { - my \maybe = $!channel.poll; - if maybe === Nil { - if $!closed_promise.status == Kept { - $notified := True; - subscriber(False, X::Channel::ReceiveOnClosed.new(:$!channel)) - } - elsif $!closed_promise.status == Broken { - $notified := True; - subscriber(False, $!closed_promise.cause) - } - } - else { - $notified := True; - subscriber(True, maybe); - } - $t.close if $notified; - } - } - } - } - } - - method get-await-handle(--> Awaitable::Handle:D) { - my \maybe = self.poll; - if maybe === Nil { - if $!closed_promise { - ChannelAwaitableHandle.already-failure( - $!closed_promise.status == Kept - ?? X::Channel::ReceiveOnClosed.new(channel => self) - !! $!closed_promise.cause - ) - } - else { - ChannelAwaitableHandle.not-ready(self, $!closed_promise, $!async-notify) - } - } - else { - ChannelAwaitableHandle.already-success(maybe) - } - } - - method close() { - $!closed = 1; - nqp::push($!queue, CHANNEL_CLOSE); - # if $!queue is otherwise empty, make sure that $!closed_promise - # learns about the new value - self!peek(); - $!async-notify.emit(True); - Nil - } - - method elems() { - Failure.new("Cannot determine number of elements on a {self.^name}") - } - - method fail($error is copy) { - $!closed = 1; - $error = X::AdHoc.new(payload => $error) unless nqp::istype($error, Exception); - nqp::push($!queue, CHANNEL_FAIL.new(:$error)); - $!async-notify.emit(True); - Nil - } - - method closed() { - self!peek(); - $!closed_promise - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Channel.pm6 rakudo-2018.03/src/core/Channel.pm6 --- rakudo-2018.02.1/src/core/Channel.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Channel.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,284 @@ +# A channel provides a thread-safe way to send a series of values from some +# producer(s) to some consumer(s). +my class X::Channel::SendOnClosed is Exception { + has $.channel; + method message() { "Cannot send a message on a closed channel" } +} +my class X::Channel::ReceiveOnClosed is Exception { + has $.channel; + method message() { "Cannot receive a message on a closed channel" } +} +my class Channel does Awaitable { + # The queue of events moving through the channel. + my class Queue is repr('ConcBlockingQueue') { } + has $!queue; + + # Promise that is triggered when all values are received, or an error is + # received and the channel is thus closed. + has $!closed_promise; + + # Closed promise's vow. + has $!closed_promise_vow; + + # Flag for if the channel is closed to senders. + has $!closed; + + # We use a Supplier to send async notifications that there may be a new + # message to read from the channel (there may be many things competing + # over them). + has $!async-notify; + + # Magical objects for various ways a channel can end. + my class CHANNEL_CLOSE { } + my class CHANNEL_FAIL { has $.error } + + submethod BUILD(--> Nil) { + $!queue := nqp::create(Queue); + $!closed_promise = Promise.new; + $!closed_promise_vow = $!closed_promise.vow; + $!async-notify = Supplier.new; + } + + method send(Channel:D: \item) { + X::Channel::SendOnClosed.new(channel => self).throw if $!closed; + nqp::push($!queue, nqp::decont(item)); + $!async-notify.emit(True); + Nil + } + + method receive(Channel:D:) { + nqp::if( + nqp::istype((my \msg := nqp::shift($!queue)),CHANNEL_CLOSE), + nqp::stmts( + nqp::push($!queue, msg), # make sure other readers see it + $!closed_promise_vow.keep(Nil), + X::Channel::ReceiveOnClosed.new(channel => self).throw + ), + nqp::if( + nqp::istype(msg,CHANNEL_FAIL), + nqp::stmts( + nqp::push($!queue,msg), # make sure other readers see it + $!closed_promise_vow.break(my $error := msg.error), + $error.rethrow + ), + msg + ) + ) + } + method receive-nil-on-close(Channel:D:) { + nqp::if( + nqp::istype((my \msg := nqp::shift($!queue)),CHANNEL_CLOSE), + nqp::stmts( + nqp::push($!queue, msg), # make sure other readers see it + $!closed_promise_vow.keep(Nil), + Nil + ), + nqp::if( + nqp::istype(msg,CHANNEL_FAIL), + nqp::stmts( + nqp::push($!queue,msg), # make sure other readers see it + $!closed_promise_vow.break(my $error := msg.error), + $error.rethrow + ), + msg + ) + ) + } + + method poll(Channel:D:) { + nqp::if( + nqp::isnull(my \msg := nqp::queuepoll($!queue)), + Nil, + nqp::if( + nqp::istype(msg, CHANNEL_CLOSE), + nqp::stmts( + $!closed_promise_vow.keep(Nil), + Nil + ), + nqp::if( + nqp::istype(msg, CHANNEL_FAIL), + nqp::stmts( + $!closed_promise_vow.break(msg.error), + Nil + ), + msg + ) + ) + ) + } + + method !peek(Channel:D:) { + my \msg := nqp::atpos($!queue, 0); + if nqp::isnull(msg) { + Nil + } else { + if nqp::istype(msg, CHANNEL_CLOSE) { + $!closed_promise_vow.keep(Nil); + Nil + } + elsif nqp::istype(msg, CHANNEL_FAIL) { + $!closed_promise_vow.break(msg.error); + Nil + } + else { + msg + } + } + } + + method Capture(Channel:D:) { self.List.Capture } + multi method Supply(Channel:D:) { + supply { + # Tap the async notification for new values supply. + whenever $!async-notify.unsanitized-supply.schedule-on($*SCHEDULER) { + my Mu \got = self.poll; + if nqp::eqaddr(got, Nil) { + if $!closed_promise { + $!closed_promise.status == Kept + ?? done() + !! die $!closed_promise.cause + } + } + else { + emit got; + } + } + + # Grab anything that's in the channel and emit it. Note that + # it's important to do this after tapping the supply, or a + # value sent between us draining it and doing the tap would + # not result in a notification, and so we'd not emit it on + # the supply. This lost event can then cause a deadlock. + loop { + my Mu \got = self.poll; + last if nqp::eqaddr(got, Nil); + emit got; + } + self!peek(); + if $!closed_promise { + $!closed_promise.status == Kept + ?? done() + !! die $!closed_promise.cause + } + } + } + + method iterator(Channel:D:) { + class :: does Iterator { + has $!channel; + method !SET-SELF($!channel) { self } + method new(\c) { nqp::create(self)!SET-SELF(c) } + method pull-one() { + my Mu \got = $!channel.receive-nil-on-close; + nqp::eqaddr(got, Nil) ?? IterationEnd !! got + } + }.new(self) + } + + method list(Channel:D:) { self.Seq.list } + + my class ChannelAwaitableHandle does Awaitable::Handle { + has $!channel; + has $!closed_promise; + has $!async-notify; + + method not-ready(Channel:D $channel, Promise:D $closed_promise, Supplier:D $async-notify) { + nqp::create(self)!not-ready($channel, $closed_promise, $async-notify) + } + method !not-ready($channel, $closed_promise, $async-notify) { + $!already = False; + $!channel := $channel; + $!closed_promise := $closed_promise; + $!async-notify := $async-notify; + self + } + + method subscribe-awaiter(&subscriber --> Nil) { + # Need some care here to avoid a race. We must tap the notification + # supply first, and then do an immediate poll after it, just to be + # sure we won't miss notifications between the two. Also, we need + # to take some care that we never call subscriber twice. + my $notified := False; + my $l := Lock.new; + my $t; + $l.protect: { + # Lock ensures $t will be assigned before we run the logic + # inside of poll-now, which relies on being able to do + # $t.close. + $t := $!async-notify.unsanitized-supply.tap: &poll-now; + } + poll-now(); + + sub poll-now($discard?) { + $l.protect: { + unless $notified { + my \maybe = $!channel.poll; + if maybe === Nil { + if $!closed_promise.status == Kept { + $notified := True; + subscriber(False, X::Channel::ReceiveOnClosed.new(:$!channel)) + } + elsif $!closed_promise.status == Broken { + $notified := True; + subscriber(False, $!closed_promise.cause) + } + } + else { + $notified := True; + subscriber(True, maybe); + } + $t.close if $notified; + } + } + } + } + } + + method get-await-handle(--> Awaitable::Handle:D) { + my \maybe = self.poll; + if maybe === Nil { + if $!closed_promise { + ChannelAwaitableHandle.already-failure( + $!closed_promise.status == Kept + ?? X::Channel::ReceiveOnClosed.new(channel => self) + !! $!closed_promise.cause + ) + } + else { + ChannelAwaitableHandle.not-ready(self, $!closed_promise, $!async-notify) + } + } + else { + ChannelAwaitableHandle.already-success(maybe) + } + } + + method close() { + $!closed = 1; + nqp::push($!queue, CHANNEL_CLOSE); + # if $!queue is otherwise empty, make sure that $!closed_promise + # learns about the new value + self!peek(); + $!async-notify.emit(True); + Nil + } + + method elems() { + Failure.new("Cannot determine number of elements on a {self.^name}") + } + + method fail($error is copy) { + $!closed = 1; + $error = X::AdHoc.new(payload => $error) unless nqp::istype($error, Exception); + nqp::push($!queue, CHANNEL_FAIL.new(:$error)); + $!async-notify.emit(True); + Nil + } + + method closed() { + self!peek(); + $!closed_promise + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Code.pm rakudo-2018.03/src/core/Code.pm --- rakudo-2018.02.1/src/core/Code.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Code.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,48 +0,0 @@ -my class Code does Callable { # declared in BOOTSTRAP - # class Code is Any - # has Code $!do; # Low level code object - # has Signature $!signature; # Signature object - # has @!compstuff; # Place for the compiler to hang stuff - - multi method ACCEPTS(Code:D $self: Mu $topic is raw) { - $self.count ?? $self($topic) !! $self() - } - - method arity(Code:D:) { nqp::getattr_i($!signature,Signature,'$!arity') } - - method count(Code:D:) { nqp::getattr($!signature,Signature,'$!count') } - - method signature(Code:D:) { $!signature } - - proto method prec(|) {*} - multi method prec() { my % } - multi method prec(Str:D $) { '' } - - multi method Str(Code:D:) { - warn( self.WHAT.perl ~ " object coerced to string (please use .gist or .perl to do that)"); self.name - } - - method outer(Code:D:) { - nqp::ifnull(nqp::getcodeobj(nqp::p6staticouter($!do)), Mu) - } - - # returns an identifier for this code object - # that is the same even for cloned closures - method static_id(Code:D:) { - nqp::p6box_i(nqp::where(nqp::getstaticcode($!do))); - } - - multi method new(Code:) { X::Cannot::New.new(class => self).throw } - - method file(Code:D:) { - nqp::getcodelocation($!do); - } - - method line(Code:D:) { - nqp::getcodelocation($!do); - } - - multi method perl(Code:D:) { '{ ... }' } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Code.pm6 rakudo-2018.03/src/core/Code.pm6 --- rakudo-2018.02.1/src/core/Code.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Code.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,48 @@ +my class Code does Callable { # declared in BOOTSTRAP + # class Code is Any + # has Code $!do; # Low level code object + # has Signature $!signature; # Signature object + # has @!compstuff; # Place for the compiler to hang stuff + + multi method ACCEPTS(Code:D $self: Mu $topic is raw) { + $self.count ?? $self($topic) !! $self() + } + + method arity(Code:D:) { nqp::getattr_i($!signature,Signature,'$!arity') } + + method count(Code:D:) { nqp::getattr($!signature,Signature,'$!count') } + + method signature(Code:D:) { $!signature } + + proto method prec(|) {*} + multi method prec() { my % } + multi method prec(Str:D $) { '' } + + multi method Str(Code:D:) { + warn( self.WHAT.perl ~ " object coerced to string (please use .gist or .perl to do that)"); self.name + } + + method outer(Code:D:) { + nqp::ifnull(nqp::getcodeobj(nqp::p6staticouter($!do)), Mu) + } + + # returns an identifier for this code object + # that is the same even for cloned closures + method static_id(Code:D:) { + nqp::p6box_i(nqp::where(nqp::getstaticcode($!do))); + } + + multi method new(Code:) { X::Cannot::New.new(class => self).throw } + + method file(Code:D:) { + nqp::getcodelocation($!do); + } + + method line(Code:D:) { + nqp::getcodelocation($!do); + } + + multi method perl(Code:D:) { '{ ... }' } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Collation.pm rakudo-2018.03/src/core/Collation.pm --- rakudo-2018.02.1/src/core/Collation.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Collation.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,52 +0,0 @@ -class Collation { - has int $.collation-level = 85; - has $!Country = 'International'; - method gist { - "collation-level => $!collation-level, Country => $!Country, " ~ - "Language => None, primary => {self.primary}, secondary => {self.secondary}, " ~ - "tertiary => {self.tertiary}, quaternary => {self.quaternary}" - } - method set ( - Int :$primary = 1, - Int :$secondary = 1, - Int :$tertiary = 1, - Int :$quaternary = 1) - { - nqp::isnull(nqp::getlexcaller('EXPERIMENTAL-COLLATION')) and X::Experimental.new( - feature => 'the $*COLLATION dynamic variable', - use => 'collation' - ).throw; - my int $i = 0; - $i += 1 if $primary.sign == 1; - $i += 2 if $primary.sign == -1; - - $i += 4 if $secondary.sign == 1; - $i += 8 if $secondary.sign == -1; - - $i += 16 if $tertiary.sign == 1; - $i += 32 if $tertiary.sign == -1; - - $i += 64 if $quaternary.sign == 1; - $i += 128 if $quaternary.sign == -1; - $!collation-level = $i; - self; - } - method check ($more, $less) { - # Hopefully the user didn't set collation-level manually to have a level - # both enabled *and* disabled. But check if this is the case anyway. - return 0 if $!collation-level +& all($more,$less); - return 1 if $!collation-level +& $more; - return -1 if $!collation-level +& $less; - return 0; - } - method primary { self.check( 1, 2) } - method secondary { self.check( 4, 8) } - method tertiary { self.check(16, 32) } - method quaternary { self.check(64, 128) } -} - -Rakudo::Internals.REGISTER-DYNAMIC: '$*COLLATION', { - PROCESS::<$COLLATION> := Collation.new; -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Collation.pm6 rakudo-2018.03/src/core/Collation.pm6 --- rakudo-2018.02.1/src/core/Collation.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Collation.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,52 @@ +class Collation { + has int $.collation-level = 85; + has $!Country = 'International'; + method gist { + "collation-level => $!collation-level, Country => $!Country, " ~ + "Language => None, primary => {self.primary}, secondary => {self.secondary}, " ~ + "tertiary => {self.tertiary}, quaternary => {self.quaternary}" + } + method set ( + Int :$primary = 1, + Int :$secondary = 1, + Int :$tertiary = 1, + Int :$quaternary = 1) + { + nqp::isnull(nqp::getlexcaller('EXPERIMENTAL-COLLATION')) and X::Experimental.new( + feature => 'the $*COLLATION dynamic variable', + use => 'collation' + ).throw; + my int $i = 0; + $i += 1 if $primary.sign == 1; + $i += 2 if $primary.sign == -1; + + $i += 4 if $secondary.sign == 1; + $i += 8 if $secondary.sign == -1; + + $i += 16 if $tertiary.sign == 1; + $i += 32 if $tertiary.sign == -1; + + $i += 64 if $quaternary.sign == 1; + $i += 128 if $quaternary.sign == -1; + $!collation-level = $i; + self; + } + method check ($more, $less) { + # Hopefully the user didn't set collation-level manually to have a level + # both enabled *and* disabled. But check if this is the case anyway. + return 0 if $!collation-level +& all($more,$less); + return 1 if $!collation-level +& $more; + return -1 if $!collation-level +& $less; + return 0; + } + method primary { self.check( 1, 2) } + method secondary { self.check( 4, 8) } + method tertiary { self.check(16, 32) } + method quaternary { self.check(64, 128) } +} + +Rakudo::Internals.REGISTER-DYNAMIC: '$*COLLATION', { + PROCESS::<$COLLATION> := Collation.new; +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Compiler.pm rakudo-2018.03/src/core/Compiler.pm --- rakudo-2018.02.1/src/core/Compiler.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Compiler.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,91 +0,0 @@ -class Compiler does Systemic { - has Str $.id; - has Str $.release; - has Str $!build-date; - has Str $.codename; - BEGIN my $id = $*W.handle.Str ~ '.' ~ nqp::time_n(); - - submethod BUILD ( - :$!name = 'rakudo', - :$!auth = 'The Perl Foundation', - :$version, - :$release, - :$build-date, - :$codename - --> Nil - ) { -# XXX Various issues with this stuff on JVM - my Mu $compiler := nqp::getcurhllsym('$COMPILER_CONFIG'); - $!id = nqp::p6box_s(nqp::ifnull(nqp::atkey($compiler,'id'),$id)); - # looks like: 2018.01-50-g8afd791c1 - $!version = $version - // Version.new(nqp::atkey($compiler, 'version')); - $!release = - $release // nqp::p6box_s(nqp::atkey($compiler, 'release-number')); - $!build-date = - $build-date // nqp::p6box_s(nqp::atkey($compiler, 'build-date')); - $!codename = - $codename // nqp::p6box_s(nqp::atkey($compiler, 'codename')); - } - - method build-date() { - DateTime.new($!build-date) - } - - method verbose-config(:$say) { - my $compiler := nqp::getcomp("perl6"); - my $backend := $compiler.backend; - my $name := $backend.name; - - my $items := nqp::list_s; - nqp::push_s($items,$name ~ '::' ~ .key ~ '=' ~ .value) - for $backend.config; - - my $language := $compiler.language; - nqp::push_s($items,$language ~ '::' ~ .key ~ '=' ~ .value) - for $compiler.config; - - nqp::push_s( - $items, - 'repo::chain=' ~ (try $*REPO.repo-chain.map( *.gist ).join(" ")) // '' - ); - - nqp::push_s($items,"distro::$_={ $*DISTRO."$_"() // '' }") - for ; - - nqp::push_s($items,"kernel::$_={ $*KERNEL."$_"() // '' }") - for ; - - try { - require System::Info; - - my $sysinfo = System::Info.new; - nqp::push_s($items,"sysinfo::{ .name }={ $sysinfo.$_ // '' }") - for $sysinfo.^methods.grep: { .count == 1 && .name ne 'new' }; - } - - my str $string = nqp::join("\n",Rakudo::Sorting.MERGESORT-str($items)); - - if $say { - nqp::say($string); - Nil - } - else { - my %config; - my $iter := nqp::iterator($items); - while $iter { - my ($main,$key,$value) = nqp::shift($iter).split(<:: =>); - %config.AT-KEY($main).AT-KEY($key) = $value - } - - %config but role { - has $!string = $string; - proto method Str() { $!string } - proto method gist() { $!string } - } - } - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Compiler.pm6 rakudo-2018.03/src/core/Compiler.pm6 --- rakudo-2018.02.1/src/core/Compiler.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Compiler.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,91 @@ +class Compiler does Systemic { + has Str $.id; + has Str $.release; + has Str $!build-date; + has Str $.codename; + BEGIN my $id = $*W.handle.Str ~ '.' ~ nqp::time_n(); + + submethod BUILD ( + :$!name = 'rakudo', + :$!auth = 'The Perl Foundation', + :$version, + :$release, + :$build-date, + :$codename + --> Nil + ) { +# XXX Various issues with this stuff on JVM + my Mu $compiler := nqp::getcurhllsym('$COMPILER_CONFIG'); + $!id = nqp::p6box_s(nqp::ifnull(nqp::atkey($compiler,'id'),$id)); + # looks like: 2018.01-50-g8afd791c1 + $!version = $version + // Version.new(nqp::atkey($compiler, 'version')); + $!release = + $release // nqp::p6box_s(nqp::atkey($compiler, 'release-number')); + $!build-date = + $build-date // nqp::p6box_s(nqp::atkey($compiler, 'build-date')); + $!codename = + $codename // nqp::p6box_s(nqp::atkey($compiler, 'codename')); + } + + method build-date() { + DateTime.new($!build-date) + } + + method verbose-config(:$say) { + my $compiler := nqp::getcomp("perl6"); + my $backend := $compiler.backend; + my $name := $backend.name; + + my $items := nqp::list_s; + nqp::push_s($items,$name ~ '::' ~ .key ~ '=' ~ .value) + for $backend.config; + + my $language := $compiler.language; + nqp::push_s($items,$language ~ '::' ~ .key ~ '=' ~ .value) + for $compiler.config; + + nqp::push_s( + $items, + 'repo::chain=' ~ (try $*REPO.repo-chain.map( *.gist ).join(" ")) // '' + ); + + nqp::push_s($items,"distro::$_={ $*DISTRO."$_"() // '' }") + for ; + + nqp::push_s($items,"kernel::$_={ $*KERNEL."$_"() // '' }") + for ; + + try { + require System::Info; + + my $sysinfo = System::Info.new; + nqp::push_s($items,"sysinfo::{ .name }={ $sysinfo.$_ // '' }") + for $sysinfo.^methods.grep: { .count == 1 && .name ne 'new' }; + } + + my str $string = nqp::join("\n",Rakudo::Sorting.MERGESORT-str($items)); + + if $say { + nqp::say($string); + Nil + } + else { + my %config; + my $iter := nqp::iterator($items); + while $iter { + my ($main,$key,$value) = nqp::shift($iter).split(<:: =>); + %config.AT-KEY($main).AT-KEY($key) = $value + } + + %config but role { + has $!string = $string; + proto method Str() { $!string } + proto method gist() { $!string } + } + } + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Complex.pm rakudo-2018.03/src/core/Complex.pm --- rakudo-2018.02.1/src/core/Complex.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Complex.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,498 +0,0 @@ -my class X::Numeric::Real { ... }; -my class Complex is Cool does Numeric { - has num $.re; - has num $.im; - - method !SET-SELF(Num() \re, Num() \im) { - $!re = re; - $!im = im; - self - } - proto method new(|) {*} - multi method new() { self.new: 0, 0 } - multi method new(Real \re, Real \im) { nqp::create(self)!SET-SELF(re, im) } - - multi method WHICH(Complex:D:) { - nqp::box_s( - nqp::concat( - nqp::if( - nqp::eqaddr(self.WHAT,Complex), - 'Complex|', - nqp::concat(nqp::unbox_s(self.^name), '|') - ), - nqp::concat($!re, nqp::concat('|', $!im)) - ), - ValueObjAt - ) - } - - method reals(Complex:D:) { - (self.re, self.im); - } - - method isNaN(Complex:D:) { - self.re.isNaN || self.im.isNaN; - } - - method coerce-to-real(Complex:D: $exception-target) { - $!im ≅ 0e0 - ?? $!re - !! Failure.new(X::Numeric::Real.new(target => $exception-target, reason => "imaginary part not zero", source => self)) - } - multi method Real(Complex:D:) { self.coerce-to-real(Real); } - - # should probably be eventually supplied by role Numeric - method Num(Complex:D:) { self.coerce-to-real(Num).Num; } - method Int(Complex:D:) { self.coerce-to-real(Int).Int; } - method Rat(Complex:D: $epsilon?) { - self.coerce-to-real(Rat).Rat( |($epsilon // Empty) ); - } - method FatRat(Complex:D: $epsilon?) { - self.coerce-to-real(FatRat).FatRat( |($epsilon // Empty) ); - } - - multi method Bool(Complex:D:) { - $!re != 0e0 || $!im != 0e0; - } - - method Complex() { self } - multi method Str(Complex:D:) { - nqp::concat( - $!re, - nqp::concat( - nqp::if(nqp::iseq_i(nqp::ord($!im),45),'','+'), - nqp::concat( - $!im, - nqp::if(nqp::isnanorinf($!im),'\\i','i') - ) - ) - ) - } - - multi method perl(Complex:D:) { - '<' ~ self.Str ~ '>'; - } - method conj(Complex:D:) { - Complex.new($.re, -$.im); - } - - method abs(Complex $x:) { - nqp::p6box_n(nqp::sqrt_n( - nqp::add_n( - nqp::mul_n($!re, $!re), - nqp::mul_n($!im, $!im), - ) - )) - } - - method polar() { - $.abs, $!im.atan2($!re); - } - multi method log(Complex:D:) { - my Num ($mag, $angle) = self.polar; - Complex.new($mag.log, $angle); - } - method cis(Complex:D:) { - self.cos + self.sin*Complex.new(0,1) - } - method sqrt(Complex:D:) { - my Num $abs = self.abs; - my Num $re = (($abs + self.re)/2).sqrt; - my Num $im = (($abs - self.re)/2).sqrt; - Complex.new($re, self.im < 0 ?? -$im !! $im); - } - - multi method exp(Complex:D:) { - my Num $mag = $!re.exp; - Complex.new($mag * $!im.cos, $mag * $!im.sin); - } - - method roots(Complex:D: Int() $n) { - return NaN if $n < 1; - return self if $n == 1; - for $!re, $!im { - return NaN if $_ eq 'Inf' || $_ eq '-Inf' || $_ eq 'NaN'; - } - - my ($mag, $angle) = self.polar; - $mag **= 1e0 / $n; - (^$n).map: { $mag.unpolar( ($angle + $_ * 2e0 * pi) / $n) }; - } - - method sin(Complex:D:) { - $!re.sin * $!im.cosh + ($!re.cos * $!im.sinh)i; - } - - method asin(Complex:D:) { - (Complex.new(0e0, -1e0) * log((self)i + sqrt(1e0 - self * self))); - } - - method cos(Complex:D:) { - $!re.cos * $!im.cosh - ($!re.sin * $!im.sinh)i; - } - - method acos(Complex:D:) { - (pi / 2e0) - self.asin; - } - - method tan(Complex:D:) { - self.sin / self.cos; - } - - method atan(Complex:D:) { - ((log(1e0 - (self)i) - log(1e0 + (self)i))i / 2e0); - } - - method sec(Complex:D:) { - 1e0 / self.cos; - } - - method asec(Complex:D:) { - (1e0 / self).acos; - } - - method cosec(Complex:D:) { - 1e0 / self.sin; - } - - method acosec(Complex:D:) { - (1e0 / self).asin; - } - - method cotan(Complex:D:) { - self.cos / self.sin; - } - - method acotan(Complex:D:) { - (1e0 / self).atan; - } - - method sinh(Complex:D:) { - -((Complex.new(0e0, 1e0) * self).sin)i; - } - - method asinh(Complex:D:) { - (self + sqrt(1e0 + self * self)).log; - } - - method cosh(Complex:D:) { - (Complex.new(0e0, 1e0) * self).cos; - } - - method acosh(Complex:D:) { - (self + sqrt(self * self - 1e0)).log; - } - - method tanh(Complex:D:) { - -((Complex.new(0e0, 1e0) * self).tan)i; - } - - method atanh(Complex:D:) { - (((1e0 + self) / (1e0 - self)).log / 2e0); - } - - method sech(Complex:D:) { - 1e0 / self.cosh; - } - - method asech(Complex:D:) { - (1e0 / self).acosh; - } - - method cosech(Complex:D:) { - 1e0 / self.sinh; - } - - method acosech(Complex:D:) { - (1e0 / self).asinh; - } - - method cotanh(Complex:D:) { - 1e0 / self.tanh; - } - - method acotanh(Complex:D:) { - (1e0 / self).atanh; - } - - method floor(Complex:D:) { - Complex.new( self.re.floor, self.im.floor ); - } - - method ceiling(Complex:D:) { - Complex.new( self.re.ceiling, self.im.ceiling ); - } - - proto method round(|) {*} - multi method round(Complex:D:) { - Complex.new( self.re.round, self.im.round ); - } - multi method round(Complex:D: Real() $scale) { - Complex.new( self.re.round($scale), self.im.round($scale) ); - } - - method truncate(Complex:D:) { - Complex.new( self.re.truncate, self.im.truncate ); - } - - method narrow(Complex:D:) { - self == 0e0 ?? 0 !! - $!re == 0e0 ?? self !! - $!im / $!re ≅ 0e0 - ?? $!re.narrow - !! self; - } -} - -multi sub prefix:<->(Complex:D \a --> Complex:D) { - my $new := nqp::create(Complex); - nqp::bindattr_n( $new, Complex, '$!re', - nqp::neg_n( - nqp::getattr_n(nqp::decont(a), Complex, '$!re') - ) - ); - nqp::bindattr_n( $new, Complex, '$!im', - nqp::neg_n( - nqp::getattr_n(nqp::decont(a), Complex, '$!im') - ) - ); - $new; -} - -multi sub abs(Complex:D \a --> Num:D) { - my num $re = nqp::getattr_n(nqp::decont(a), Complex, '$!re'); - my num $im = nqp::getattr_n(nqp::decont(a), Complex, '$!im'); - nqp::p6box_n(nqp::sqrt_n(nqp::add_n(nqp::mul_n($re, $re), nqp::mul_n($im, $im)))); -} - -multi sub infix:<+>(Complex:D \a, Complex:D \b --> Complex:D) { - my $new := nqp::create(Complex); - nqp::bindattr_n( $new, Complex, '$!re', - nqp::add_n( - nqp::getattr_n(nqp::decont(a), Complex, '$!re'), - nqp::getattr_n(nqp::decont(b), Complex, '$!re'), - ) - ); - nqp::bindattr_n( $new, Complex, '$!im', - nqp::add_n( - nqp::getattr_n(nqp::decont(a), Complex, '$!im'), - nqp::getattr_n(nqp::decont(b), Complex, '$!im'), - ) - ); - $new; -} - -multi sub infix:<+>(Complex:D \a, Num(Real) \b --> Complex:D) { - my $new := nqp::create(Complex); - nqp::bindattr_n( $new, Complex, '$!re', - nqp::add_n( - nqp::getattr_n(nqp::decont(a), Complex, '$!re'), - nqp::unbox_n(b) - ) - ); - nqp::bindattr_n($new, Complex, '$!im', - nqp::getattr_n(nqp::decont(a), Complex, '$!im'), - ); - $new -} - -multi sub infix:<+>(Num(Real) \a, Complex:D \b --> Complex:D) { - my $new := nqp::create(Complex); - nqp::bindattr_n($new, Complex, '$!re', - nqp::add_n( - nqp::unbox_n(a), - nqp::getattr_n(nqp::decont(b), Complex, '$!re'), - ) - ); - nqp::bindattr_n($new, Complex, '$!im', - nqp::getattr_n(nqp::decont(b), Complex, '$!im'), - ); - $new; -} - -multi sub infix:<->(Complex:D \a, Complex:D \b --> Complex:D) { - my $new := nqp::create(Complex); - nqp::bindattr_n( $new, Complex, '$!re', - nqp::sub_n( - nqp::getattr_n(nqp::decont(a), Complex, '$!re'), - nqp::getattr_n(nqp::decont(b), Complex, '$!re'), - ) - ); - nqp::bindattr_n($new, Complex, '$!im', - nqp::sub_n( - nqp::getattr_n(nqp::decont(a), Complex, '$!im'), - nqp::getattr_n(nqp::decont(b), Complex, '$!im'), - ) - ); - $new -} - -multi sub infix:<->(Complex:D \a, Num(Real) \b --> Complex:D) { - my $new := nqp::create(Complex); - nqp::bindattr_n( $new, Complex, '$!re', - nqp::sub_n( - nqp::getattr_n(nqp::decont(a), Complex, '$!re'), - b, - ) - ); - nqp::bindattr_n($new, Complex, '$!im', - nqp::getattr_n(nqp::decont(a), Complex, '$!im') - ); - $new -} - -multi sub infix:<->(Num(Real) \a, Complex:D \b --> Complex:D) { - my $new := nqp::create(Complex); - nqp::bindattr_n( $new, Complex, '$!re', - nqp::sub_n( - a, - nqp::getattr_n(nqp::decont(b), Complex, '$!re'), - ) - ); - nqp::bindattr_n($new, Complex, '$!im', - nqp::neg_n( - nqp::getattr_n(nqp::decont(b), Complex, '$!im') - ) - ); - $new -} - -multi sub infix:<*>(Complex:D \a, Complex:D \b --> Complex:D) { - my num $a_re = nqp::getattr_n(nqp::decont(a), Complex, '$!re'); - my num $a_im = nqp::getattr_n(nqp::decont(a), Complex, '$!im'); - my num $b_re = nqp::getattr_n(nqp::decont(b), Complex, '$!re'); - my num $b_im = nqp::getattr_n(nqp::decont(b), Complex, '$!im'); - my $new := nqp::create(Complex); - nqp::bindattr_n($new, Complex, '$!re', - nqp::sub_n(nqp::mul_n($a_re, $b_re), nqp::mul_n($a_im, $b_im)), - ); - nqp::bindattr_n($new, Complex, '$!im', - nqp::add_n(nqp::mul_n($a_re, $b_im), nqp::mul_n($a_im, $b_re)), - ); - $new; -} - -multi sub infix:<*>(Complex:D \a, Num(Real) \b --> Complex:D) { - my $new := nqp::create(Complex); - my num $b_num = b; - nqp::bindattr_n($new, Complex, '$!re', - nqp::mul_n( - nqp::getattr_n(nqp::decont(a), Complex, '$!re'), - $b_num, - ) - ); - nqp::bindattr_n($new, Complex, '$!im', - nqp::mul_n( - nqp::getattr_n(nqp::decont(a), Complex, '$!im'), - $b_num, - ) - ); - $new -} - -multi sub infix:<*>(Num(Real) \a, Complex:D \b --> Complex:D) { - my $new := nqp::create(Complex); - my num $a_num = a; - nqp::bindattr_n($new, Complex, '$!re', - nqp::mul_n( - $a_num, - nqp::getattr_n(nqp::decont(b), Complex, '$!re'), - ) - ); - nqp::bindattr_n($new, Complex, '$!im', - nqp::mul_n( - $a_num, - nqp::getattr_n(nqp::decont(b), Complex, '$!im'), - ) - ); - $new -} - -multi sub infix:(Complex:D \a, Complex:D \b --> Complex:D) { - my num $a_re = nqp::getattr_n(nqp::decont(a), Complex, '$!re'); - my num $a_im = nqp::getattr_n(nqp::decont(a), Complex, '$!im'); - my num $b_re = nqp::getattr_n(nqp::decont(b), Complex, '$!re'); - my num $b_im = nqp::getattr_n(nqp::decont(b), Complex, '$!im'); - my num $d = nqp::add_n(nqp::mul_n($b_re, $b_re), nqp::mul_n($b_im, $b_im)); - my $new := nqp::create(Complex); - nqp::bindattr_n($new, Complex, '$!re', - nqp::div_n( - nqp::add_n(nqp::mul_n($a_re, $b_re), nqp::mul_n($a_im, $b_im)), - $d, - ) - ); - nqp::bindattr_n($new, Complex, '$!im', - nqp::div_n( - nqp::sub_n(nqp::mul_n($a_im, $b_re), nqp::mul_n($a_re, $b_im)), - $d, - ) - ); - $new; -} - -multi sub infix:(Complex:D \a, Real \b --> Complex:D) { - Complex.new(a.re / b, a.im / b); -} - -multi sub infix:(Real \a, Complex:D \b --> Complex:D) { - Complex.new(a, 0e0) / b; -} - -multi sub infix:<**>(Complex:D \a, Complex:D \b --> Complex:D) { - (a.re == 0e0 && a.im == 0e0) - ?? ( b.re == 0e0 && b.im == 0e0 - ?? Complex.new(1e0, 0e0) - !! Complex.new(0e0, 0e0) - ) - !! (b * a.log).exp -} -multi sub infix:<**>(Num(Real) \a, Complex:D \b --> Complex:D) { - a == 0e0 - ?? ( b.re == 0e0 && b.im == 0e0 - ?? Complex.new(1e0, 0e0) - !! Complex.new(0e0, 0e0) - ) - !! (b * a.log).exp -} -multi sub infix:<**>(Complex:D \a, Num(Real) \b --> Complex:D) { - b == 0e0 ?? Complex.new(1e0, 0e0) !! (b * a.log).exp -} - -multi sub infix:<==>(Complex:D \a, Complex:D \b --> Bool:D) { a.re == b.re && a.im == b.im } -multi sub infix:<==>(Complex:D \a, Num(Real) \b --> Bool:D) { a.re == b && a.im == 0e0 } -multi sub infix:<==>(Num(Real) \a, Complex:D \b --> Bool:D) { a == b.re && 0e0 == b.im } -multi sub infix:<===>(Complex:D \a, Complex:D \b --> Bool:D) { - a.WHAT =:= b.WHAT && a.re === b.re && a.im === b.im -} - -multi sub infix:<≅>(Complex:D \a, Complex:D \b --> Bool:D) { a.re ≅ b.re && a.im ≅ b.im || a <=> b =:= Same } -multi sub infix:<≅>(Complex:D \a, Num(Real) \b --> Bool:D) { a ≅ b.Complex } -multi sub infix:<≅>(Num(Real) \a, Complex:D \b --> Bool:D) { a.Complex ≅ b } - -# Meaningful only for sorting purposes, of course. -# We delegate to Real::cmp rather than <=> because parts might be NaN. -multi sub infix:(Complex:D \a, Complex:D \b --> Order:D) { a.re cmp b.re || a.im cmp b.im } -multi sub infix:(Num(Real) \a, Complex:D \b --> Order:D) { a cmp b.re || 0 cmp b.im } -multi sub infix:(Complex:D \a, Num(Real) \b --> Order:D) { a.re cmp b || a.im cmp 0 } - -multi sub infix:«<=>»(Complex:D \a, Complex:D \b --> Order:D) { - my $tolerance = a && b - ?? (a.re.abs + b.re.abs) / 2 * $*TOLERANCE # Scale slop to average real parts. - !! $*TOLERANCE; # Don't want tolerance 0 if either arg is 0. - # Fail unless imaginary parts are relatively negligible, compared to real parts. - infix:<≅>(a.im, 0e0, :$tolerance) && infix:<≅>(b.im, 0e0, :$tolerance) - ?? a.re <=> b.re - !! Failure.new(X::Numeric::Real.new(target => Real, reason => "Complex is not numerically orderable", source => "Complex")) -} -multi sub infix:«<=>»(Num(Real) \a, Complex:D \b --> Order:D) { a.Complex <=> b } -multi sub infix:«<=>»(Complex:D \a, Num(Real) \b --> Order:D) { a <=> b.Complex } - -proto sub postfix:(\a --> Complex:D) is pure {*} -multi sub postfix:(Real \a --> Complex:D) { Complex.new(0e0, a); } -multi sub postfix:(Complex:D \a --> Complex:D) { Complex.new(-a.im, a.re) } -multi sub postfix:(Numeric \a --> Complex:D) { a * Complex.new(0e0, 1e0) } -multi sub postfix:(Cool \a --> Complex:D) { a.Numeric * Complex.new(0e0, 1e0) } - -constant i = Complex.new(0e0, 1e0); - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Complex.pm6 rakudo-2018.03/src/core/Complex.pm6 --- rakudo-2018.02.1/src/core/Complex.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Complex.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,498 @@ +my class X::Numeric::Real { ... }; +my class Complex is Cool does Numeric { + has num $.re; + has num $.im; + + method !SET-SELF(Num() \re, Num() \im) { + $!re = re; + $!im = im; + self + } + proto method new(|) {*} + multi method new() { self.new: 0, 0 } + multi method new(Real \re, Real \im) { nqp::create(self)!SET-SELF(re, im) } + + multi method WHICH(Complex:D:) { + nqp::box_s( + nqp::concat( + nqp::if( + nqp::eqaddr(self.WHAT,Complex), + 'Complex|', + nqp::concat(nqp::unbox_s(self.^name), '|') + ), + nqp::concat($!re, nqp::concat('|', $!im)) + ), + ValueObjAt + ) + } + + method reals(Complex:D:) { + (self.re, self.im); + } + + method isNaN(Complex:D:) { + self.re.isNaN || self.im.isNaN; + } + + method coerce-to-real(Complex:D: $exception-target) { + $!im ≅ 0e0 + ?? $!re + !! Failure.new(X::Numeric::Real.new(target => $exception-target, reason => "imaginary part not zero", source => self)) + } + multi method Real(Complex:D:) { self.coerce-to-real(Real); } + + # should probably be eventually supplied by role Numeric + method Num(Complex:D:) { self.coerce-to-real(Num).Num; } + method Int(Complex:D:) { self.coerce-to-real(Int).Int; } + method Rat(Complex:D: $epsilon?) { + self.coerce-to-real(Rat).Rat( |($epsilon // Empty) ); + } + method FatRat(Complex:D: $epsilon?) { + self.coerce-to-real(FatRat).FatRat( |($epsilon // Empty) ); + } + + multi method Bool(Complex:D:) { + $!re != 0e0 || $!im != 0e0; + } + + method Complex() { self } + multi method Str(Complex:D:) { + nqp::concat( + $!re, + nqp::concat( + nqp::if(nqp::iseq_i(nqp::ord($!im),45),'','+'), + nqp::concat( + $!im, + nqp::if(nqp::isnanorinf($!im),'\\i','i') + ) + ) + ) + } + + multi method perl(Complex:D:) { + '<' ~ self.Str ~ '>'; + } + method conj(Complex:D:) { + Complex.new($.re, -$.im); + } + + method abs(Complex $x:) { + nqp::p6box_n(nqp::sqrt_n( + nqp::add_n( + nqp::mul_n($!re, $!re), + nqp::mul_n($!im, $!im), + ) + )) + } + + method polar() { + $.abs, $!im.atan2($!re); + } + multi method log(Complex:D:) { + my Num ($mag, $angle) = self.polar; + Complex.new($mag.log, $angle); + } + method cis(Complex:D:) { + self.cos + self.sin*Complex.new(0,1) + } + method sqrt(Complex:D:) { + my Num $abs = self.abs; + my Num $re = (($abs + self.re)/2).sqrt; + my Num $im = (($abs - self.re)/2).sqrt; + Complex.new($re, self.im < 0 ?? -$im !! $im); + } + + multi method exp(Complex:D:) { + my Num $mag = $!re.exp; + Complex.new($mag * $!im.cos, $mag * $!im.sin); + } + + method roots(Complex:D: Int() $n) { + return NaN if $n < 1; + return self if $n == 1; + for $!re, $!im { + return NaN if $_ eq 'Inf' || $_ eq '-Inf' || $_ eq 'NaN'; + } + + my ($mag, $angle) = self.polar; + $mag **= 1e0 / $n; + (^$n).map: { $mag.unpolar( ($angle + $_ * 2e0 * pi) / $n) }; + } + + method sin(Complex:D:) { + $!re.sin * $!im.cosh + ($!re.cos * $!im.sinh)i; + } + + method asin(Complex:D:) { + (Complex.new(0e0, -1e0) * log((self)i + sqrt(1e0 - self * self))); + } + + method cos(Complex:D:) { + $!re.cos * $!im.cosh - ($!re.sin * $!im.sinh)i; + } + + method acos(Complex:D:) { + (pi / 2e0) - self.asin; + } + + method tan(Complex:D:) { + self.sin / self.cos; + } + + method atan(Complex:D:) { + ((log(1e0 - (self)i) - log(1e0 + (self)i))i / 2e0); + } + + method sec(Complex:D:) { + 1e0 / self.cos; + } + + method asec(Complex:D:) { + (1e0 / self).acos; + } + + method cosec(Complex:D:) { + 1e0 / self.sin; + } + + method acosec(Complex:D:) { + (1e0 / self).asin; + } + + method cotan(Complex:D:) { + self.cos / self.sin; + } + + method acotan(Complex:D:) { + (1e0 / self).atan; + } + + method sinh(Complex:D:) { + -((Complex.new(0e0, 1e0) * self).sin)i; + } + + method asinh(Complex:D:) { + (self + sqrt(1e0 + self * self)).log; + } + + method cosh(Complex:D:) { + (Complex.new(0e0, 1e0) * self).cos; + } + + method acosh(Complex:D:) { + (self + sqrt(self * self - 1e0)).log; + } + + method tanh(Complex:D:) { + -((Complex.new(0e0, 1e0) * self).tan)i; + } + + method atanh(Complex:D:) { + (((1e0 + self) / (1e0 - self)).log / 2e0); + } + + method sech(Complex:D:) { + 1e0 / self.cosh; + } + + method asech(Complex:D:) { + (1e0 / self).acosh; + } + + method cosech(Complex:D:) { + 1e0 / self.sinh; + } + + method acosech(Complex:D:) { + (1e0 / self).asinh; + } + + method cotanh(Complex:D:) { + 1e0 / self.tanh; + } + + method acotanh(Complex:D:) { + (1e0 / self).atanh; + } + + method floor(Complex:D:) { + Complex.new( self.re.floor, self.im.floor ); + } + + method ceiling(Complex:D:) { + Complex.new( self.re.ceiling, self.im.ceiling ); + } + + proto method round(|) {*} + multi method round(Complex:D:) { + Complex.new( self.re.round, self.im.round ); + } + multi method round(Complex:D: Real() $scale) { + Complex.new( self.re.round($scale), self.im.round($scale) ); + } + + method truncate(Complex:D:) { + Complex.new( self.re.truncate, self.im.truncate ); + } + + method narrow(Complex:D:) { + self == 0e0 ?? 0 !! + $!re == 0e0 ?? self !! + $!im / $!re ≅ 0e0 + ?? $!re.narrow + !! self; + } +} + +multi sub prefix:<->(Complex:D \a --> Complex:D) { + my $new := nqp::create(Complex); + nqp::bindattr_n( $new, Complex, '$!re', + nqp::neg_n( + nqp::getattr_n(nqp::decont(a), Complex, '$!re') + ) + ); + nqp::bindattr_n( $new, Complex, '$!im', + nqp::neg_n( + nqp::getattr_n(nqp::decont(a), Complex, '$!im') + ) + ); + $new; +} + +multi sub abs(Complex:D \a --> Num:D) { + my num $re = nqp::getattr_n(nqp::decont(a), Complex, '$!re'); + my num $im = nqp::getattr_n(nqp::decont(a), Complex, '$!im'); + nqp::p6box_n(nqp::sqrt_n(nqp::add_n(nqp::mul_n($re, $re), nqp::mul_n($im, $im)))); +} + +multi sub infix:<+>(Complex:D \a, Complex:D \b --> Complex:D) { + my $new := nqp::create(Complex); + nqp::bindattr_n( $new, Complex, '$!re', + nqp::add_n( + nqp::getattr_n(nqp::decont(a), Complex, '$!re'), + nqp::getattr_n(nqp::decont(b), Complex, '$!re'), + ) + ); + nqp::bindattr_n( $new, Complex, '$!im', + nqp::add_n( + nqp::getattr_n(nqp::decont(a), Complex, '$!im'), + nqp::getattr_n(nqp::decont(b), Complex, '$!im'), + ) + ); + $new; +} + +multi sub infix:<+>(Complex:D \a, Num(Real) \b --> Complex:D) { + my $new := nqp::create(Complex); + nqp::bindattr_n( $new, Complex, '$!re', + nqp::add_n( + nqp::getattr_n(nqp::decont(a), Complex, '$!re'), + nqp::unbox_n(b) + ) + ); + nqp::bindattr_n($new, Complex, '$!im', + nqp::getattr_n(nqp::decont(a), Complex, '$!im'), + ); + $new +} + +multi sub infix:<+>(Num(Real) \a, Complex:D \b --> Complex:D) { + my $new := nqp::create(Complex); + nqp::bindattr_n($new, Complex, '$!re', + nqp::add_n( + nqp::unbox_n(a), + nqp::getattr_n(nqp::decont(b), Complex, '$!re'), + ) + ); + nqp::bindattr_n($new, Complex, '$!im', + nqp::getattr_n(nqp::decont(b), Complex, '$!im'), + ); + $new; +} + +multi sub infix:<->(Complex:D \a, Complex:D \b --> Complex:D) { + my $new := nqp::create(Complex); + nqp::bindattr_n( $new, Complex, '$!re', + nqp::sub_n( + nqp::getattr_n(nqp::decont(a), Complex, '$!re'), + nqp::getattr_n(nqp::decont(b), Complex, '$!re'), + ) + ); + nqp::bindattr_n($new, Complex, '$!im', + nqp::sub_n( + nqp::getattr_n(nqp::decont(a), Complex, '$!im'), + nqp::getattr_n(nqp::decont(b), Complex, '$!im'), + ) + ); + $new +} + +multi sub infix:<->(Complex:D \a, Num(Real) \b --> Complex:D) { + my $new := nqp::create(Complex); + nqp::bindattr_n( $new, Complex, '$!re', + nqp::sub_n( + nqp::getattr_n(nqp::decont(a), Complex, '$!re'), + b, + ) + ); + nqp::bindattr_n($new, Complex, '$!im', + nqp::getattr_n(nqp::decont(a), Complex, '$!im') + ); + $new +} + +multi sub infix:<->(Num(Real) \a, Complex:D \b --> Complex:D) { + my $new := nqp::create(Complex); + nqp::bindattr_n( $new, Complex, '$!re', + nqp::sub_n( + a, + nqp::getattr_n(nqp::decont(b), Complex, '$!re'), + ) + ); + nqp::bindattr_n($new, Complex, '$!im', + nqp::neg_n( + nqp::getattr_n(nqp::decont(b), Complex, '$!im') + ) + ); + $new +} + +multi sub infix:<*>(Complex:D \a, Complex:D \b --> Complex:D) { + my num $a_re = nqp::getattr_n(nqp::decont(a), Complex, '$!re'); + my num $a_im = nqp::getattr_n(nqp::decont(a), Complex, '$!im'); + my num $b_re = nqp::getattr_n(nqp::decont(b), Complex, '$!re'); + my num $b_im = nqp::getattr_n(nqp::decont(b), Complex, '$!im'); + my $new := nqp::create(Complex); + nqp::bindattr_n($new, Complex, '$!re', + nqp::sub_n(nqp::mul_n($a_re, $b_re), nqp::mul_n($a_im, $b_im)), + ); + nqp::bindattr_n($new, Complex, '$!im', + nqp::add_n(nqp::mul_n($a_re, $b_im), nqp::mul_n($a_im, $b_re)), + ); + $new; +} + +multi sub infix:<*>(Complex:D \a, Num(Real) \b --> Complex:D) { + my $new := nqp::create(Complex); + my num $b_num = b; + nqp::bindattr_n($new, Complex, '$!re', + nqp::mul_n( + nqp::getattr_n(nqp::decont(a), Complex, '$!re'), + $b_num, + ) + ); + nqp::bindattr_n($new, Complex, '$!im', + nqp::mul_n( + nqp::getattr_n(nqp::decont(a), Complex, '$!im'), + $b_num, + ) + ); + $new +} + +multi sub infix:<*>(Num(Real) \a, Complex:D \b --> Complex:D) { + my $new := nqp::create(Complex); + my num $a_num = a; + nqp::bindattr_n($new, Complex, '$!re', + nqp::mul_n( + $a_num, + nqp::getattr_n(nqp::decont(b), Complex, '$!re'), + ) + ); + nqp::bindattr_n($new, Complex, '$!im', + nqp::mul_n( + $a_num, + nqp::getattr_n(nqp::decont(b), Complex, '$!im'), + ) + ); + $new +} + +multi sub infix:(Complex:D \a, Complex:D \b --> Complex:D) { + my num $a_re = nqp::getattr_n(nqp::decont(a), Complex, '$!re'); + my num $a_im = nqp::getattr_n(nqp::decont(a), Complex, '$!im'); + my num $b_re = nqp::getattr_n(nqp::decont(b), Complex, '$!re'); + my num $b_im = nqp::getattr_n(nqp::decont(b), Complex, '$!im'); + my num $d = nqp::add_n(nqp::mul_n($b_re, $b_re), nqp::mul_n($b_im, $b_im)); + my $new := nqp::create(Complex); + nqp::bindattr_n($new, Complex, '$!re', + nqp::div_n( + nqp::add_n(nqp::mul_n($a_re, $b_re), nqp::mul_n($a_im, $b_im)), + $d, + ) + ); + nqp::bindattr_n($new, Complex, '$!im', + nqp::div_n( + nqp::sub_n(nqp::mul_n($a_im, $b_re), nqp::mul_n($a_re, $b_im)), + $d, + ) + ); + $new; +} + +multi sub infix:(Complex:D \a, Real \b --> Complex:D) { + Complex.new(a.re / b, a.im / b); +} + +multi sub infix:(Real \a, Complex:D \b --> Complex:D) { + Complex.new(a, 0e0) / b; +} + +multi sub infix:<**>(Complex:D \a, Complex:D \b --> Complex:D) { + (a.re == 0e0 && a.im == 0e0) + ?? ( b.re == 0e0 && b.im == 0e0 + ?? Complex.new(1e0, 0e0) + !! Complex.new(0e0, 0e0) + ) + !! (b * a.log).exp +} +multi sub infix:<**>(Num(Real) \a, Complex:D \b --> Complex:D) { + a == 0e0 + ?? ( b.re == 0e0 && b.im == 0e0 + ?? Complex.new(1e0, 0e0) + !! Complex.new(0e0, 0e0) + ) + !! (b * a.log).exp +} +multi sub infix:<**>(Complex:D \a, Num(Real) \b --> Complex:D) { + b == 0e0 ?? Complex.new(1e0, 0e0) !! (b * a.log).exp +} + +multi sub infix:<==>(Complex:D \a, Complex:D \b --> Bool:D) { a.re == b.re && a.im == b.im } +multi sub infix:<==>(Complex:D \a, Num(Real) \b --> Bool:D) { a.re == b && a.im == 0e0 } +multi sub infix:<==>(Num(Real) \a, Complex:D \b --> Bool:D) { a == b.re && 0e0 == b.im } +multi sub infix:<===>(Complex:D \a, Complex:D \b --> Bool:D) { + a.WHAT =:= b.WHAT && a.re === b.re && a.im === b.im +} + +multi sub infix:<≅>(Complex:D \a, Complex:D \b --> Bool:D) { a.re ≅ b.re && a.im ≅ b.im || a <=> b =:= Same } +multi sub infix:<≅>(Complex:D \a, Num(Real) \b --> Bool:D) { a ≅ b.Complex } +multi sub infix:<≅>(Num(Real) \a, Complex:D \b --> Bool:D) { a.Complex ≅ b } + +# Meaningful only for sorting purposes, of course. +# We delegate to Real::cmp rather than <=> because parts might be NaN. +multi sub infix:(Complex:D \a, Complex:D \b --> Order:D) { a.re cmp b.re || a.im cmp b.im } +multi sub infix:(Num(Real) \a, Complex:D \b --> Order:D) { a cmp b.re || 0 cmp b.im } +multi sub infix:(Complex:D \a, Num(Real) \b --> Order:D) { a.re cmp b || a.im cmp 0 } + +multi sub infix:«<=>»(Complex:D \a, Complex:D \b --> Order:D) { + my $tolerance = a && b + ?? (a.re.abs + b.re.abs) / 2 * $*TOLERANCE # Scale slop to average real parts. + !! $*TOLERANCE; # Don't want tolerance 0 if either arg is 0. + # Fail unless imaginary parts are relatively negligible, compared to real parts. + infix:<≅>(a.im, 0e0, :$tolerance) && infix:<≅>(b.im, 0e0, :$tolerance) + ?? a.re <=> b.re + !! Failure.new(X::Numeric::Real.new(target => Real, reason => "Complex is not numerically orderable", source => "Complex")) +} +multi sub infix:«<=>»(Num(Real) \a, Complex:D \b --> Order:D) { a.Complex <=> b } +multi sub infix:«<=>»(Complex:D \a, Num(Real) \b --> Order:D) { a <=> b.Complex } + +proto sub postfix:(\a --> Complex:D) is pure {*} +multi sub postfix:(Real \a --> Complex:D) { Complex.new(0e0, a); } +multi sub postfix:(Complex:D \a --> Complex:D) { Complex.new(-a.im, a.re) } +multi sub postfix:(Numeric \a --> Complex:D) { a * Complex.new(0e0, 1e0) } +multi sub postfix:(Cool \a --> Complex:D) { a.Numeric * Complex.new(0e0, 1e0) } + +constant i = Complex.new(0e0, 1e0); + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/DependencySpecification.pm rakudo-2018.03/src/core/CompUnit/DependencySpecification.pm --- rakudo-2018.02.1/src/core/CompUnit/DependencySpecification.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/DependencySpecification.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,17 +0,0 @@ -class CompUnit::DependencySpecification { - has str $.short-name is required; - has int $.source-line-number = 0; - has str $.from = 'Perl6'; - has $.version-matcher = True; - has $.auth-matcher = True; - has $.api-matcher = True; - - method Str(CompUnit::DependencySpecification:D:) { - join '', $.short-name, - ($.version-matcher//True) ~~ Bool ?? '' !! ":ver<$.version-matcher>", - ($.auth-matcher //True) ~~ Bool ?? '' !! ":auth<$.auth-matcher>", - ($.api-matcher //True) ~~ Bool ?? '' !! ":api<$.api-matcher>"; - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/DependencySpecification.pm6 rakudo-2018.03/src/core/CompUnit/DependencySpecification.pm6 --- rakudo-2018.02.1/src/core/CompUnit/DependencySpecification.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/DependencySpecification.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,17 @@ +class CompUnit::DependencySpecification { + has str $.short-name is required; + has int $.source-line-number = 0; + has str $.from = 'Perl6'; + has $.version-matcher = True; + has $.auth-matcher = True; + has $.api-matcher = True; + + method Str(CompUnit::DependencySpecification:D:) { + join '', $.short-name, + ($.version-matcher//True) ~~ Bool ?? '' !! ":ver<$.version-matcher>", + ($.auth-matcher //True) ~~ Bool ?? '' !! ":auth<$.auth-matcher>", + ($.api-matcher //True) ~~ Bool ?? '' !! ":api<$.api-matcher>"; + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Handle.pm rakudo-2018.03/src/core/CompUnit/Handle.pm --- rakudo-2018.02.1/src/core/CompUnit/Handle.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Handle.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,83 +0,0 @@ -class CompUnit::Handle { - has Mu $!module_ctx; - has Mu $!unit; - - multi submethod new() { - nqp::create(self) - } - - method ctxsave() { - $!module_ctx := nqp::ctxcaller(nqp::ctx()) unless $!module_ctx; - } - - multi submethod new(Mu \module_ctx) { - nqp::p6bindattrinvres( - nqp::create(self),CompUnit::Handle,'$!module_ctx', module_ctx - ) - } - - submethod from-unit(Stash $unit) { - nqp::p6bindattrinvres( - nqp::create(self),CompUnit::Handle,'$!unit',nqp::decont($unit) - ) - } - - # If the compilation unit has a callable EXPORT subroutine, it will - # be returned here. Nil otherwise. - method export-sub(--> Callable:D) { - my $module := self.unit; - $module && nqp::existskey($module, '&EXPORT') - ?? nqp::atkey($module, '&EXPORT') - !! Nil - } - - # The EXPORT package from the UNIT of the compilation unit; a - # Nil if none - method export-package(--> Stash:D) { - my $module := self.unit; - if $module and nqp::existskey($module, 'EXPORT') { - my $EXPORT := nqp::atkey($module, 'EXPORT'); - nqp::istype($EXPORT.WHO, Stash) - ?? $EXPORT.WHO - !! nqp::p6bindattrinvres(nqp::create(Stash), Map, '$!storage', $EXPORT.WHO); - } - else { - Nil - } - } - - # The EXPORTHOW package from the UNIT of the compilation unit; - # Nil if none. - method export-how-package(--> Stash:D) { - my $module := self.unit; - if $module and nqp::existskey($module, 'EXPORTHOW') { - my $EXPORTHOW := nqp::atkey($module, 'EXPORTHOW'); - my $who := $EXPORTHOW.WHO; - nqp::istype($who, Stash) - ?? $who - !! nqp::p6bindattrinvres(nqp::create(Stash), Map, '$!storage', $who); - } - else { - Nil - } - } - - # The GLOBALish package from the UNIT of the compilation unit - # (the module's contributions to GLOBAL, for merging); - # Nil if none. - method globalish-package() { # returns Stash { - nqp::if( - nqp::defined($!module_ctx), - nqp::ifnull(nqp::atkey(nqp::ctxlexpad($!module_ctx),'GLOBALish').WHO, Nil), - nqp::if(nqp::defined($!unit), $!unit, Nil) - ) - } - - method unit() { - nqp::defined($!unit) - ?? $!unit - !! nqp::defined($!module_ctx) ?? nqp::ctxlexpad($!module_ctx) !! {} - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Handle.pm6 rakudo-2018.03/src/core/CompUnit/Handle.pm6 --- rakudo-2018.02.1/src/core/CompUnit/Handle.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Handle.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,83 @@ +class CompUnit::Handle { + has Mu $!module_ctx; + has Mu $!unit; + + multi submethod new() { + nqp::create(self) + } + + method ctxsave() { + $!module_ctx := nqp::ctxcaller(nqp::ctx()) unless $!module_ctx; + } + + multi submethod new(Mu \module_ctx) { + nqp::p6bindattrinvres( + nqp::create(self),CompUnit::Handle,'$!module_ctx', module_ctx + ) + } + + submethod from-unit(Stash $unit) { + nqp::p6bindattrinvres( + nqp::create(self),CompUnit::Handle,'$!unit',nqp::decont($unit) + ) + } + + # If the compilation unit has a callable EXPORT subroutine, it will + # be returned here. Nil otherwise. + method export-sub(--> Callable:D) { + my $module := self.unit; + $module && nqp::existskey($module, '&EXPORT') + ?? nqp::atkey($module, '&EXPORT') + !! Nil + } + + # The EXPORT package from the UNIT of the compilation unit; a + # Nil if none + method export-package(--> Stash:D) { + my $module := self.unit; + if $module and nqp::existskey($module, 'EXPORT') { + my $EXPORT := nqp::atkey($module, 'EXPORT'); + nqp::istype($EXPORT.WHO, Stash) + ?? $EXPORT.WHO + !! nqp::p6bindattrinvres(nqp::create(Stash), Map, '$!storage', $EXPORT.WHO); + } + else { + Nil + } + } + + # The EXPORTHOW package from the UNIT of the compilation unit; + # Nil if none. + method export-how-package(--> Stash:D) { + my $module := self.unit; + if $module and nqp::existskey($module, 'EXPORTHOW') { + my $EXPORTHOW := nqp::atkey($module, 'EXPORTHOW'); + my $who := $EXPORTHOW.WHO; + nqp::istype($who, Stash) + ?? $who + !! nqp::p6bindattrinvres(nqp::create(Stash), Map, '$!storage', $who); + } + else { + Nil + } + } + + # The GLOBALish package from the UNIT of the compilation unit + # (the module's contributions to GLOBAL, for merging); + # Nil if none. + method globalish-package() { # returns Stash { + nqp::if( + nqp::defined($!module_ctx), + nqp::ifnull(nqp::atkey(nqp::ctxlexpad($!module_ctx),'GLOBALish').WHO, Nil), + nqp::if(nqp::defined($!unit), $!unit, Nil) + ) + } + + method unit() { + nqp::defined($!unit) + ?? $!unit + !! nqp::defined($!module_ctx) ?? nqp::ctxlexpad($!module_ctx) !! {} + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Loader.pm rakudo-2018.03/src/core/CompUnit/Loader.pm --- rakudo-2018.02.1/src/core/CompUnit/Loader.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Loader.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,66 +0,0 @@ -class CompUnit::Loader is repr('Uninstantiable') { - # Load a file from source and compile it - method load-source-file(IO::Path $path --> CompUnit::Handle) { - # Get the compiler and compile the code, then run it - # (which runs the mainline and captures UNIT). - my $?FILES := $path.Str; - self.load-source($path.slurp(:bin)) - } - - # Decode the specified byte buffer as source code, and compile it - method load-source(Blob:D $bytes --> CompUnit::Handle:D) { - my $preserve_global := nqp::ifnull(nqp::gethllsym('perl6', 'GLOBAL'), Mu); - - my $handle := CompUnit::Handle.new; - my $*CTXSAVE := $handle; - my $eval := nqp::getcomp('perl6').compile($bytes.decode); - - $eval(); - - nqp::bindhllsym('perl6', 'GLOBAL', $preserve_global); - - CATCH { - default { - nqp::bindhllsym('perl6', 'GLOBAL', $preserve_global); - .throw; - } - } - - $handle - } - - # Load a pre-compiled file - proto method load-precompilation-file(|) {*} - multi method load-precompilation-file(IO::Path $path --> CompUnit::Handle:D) { - my $handle := CompUnit::Handle.new; - my $*CTXSAVE := $handle; - my %*COMPILING := nqp::hash(); - nqp::loadbytecode($path.Str); - $handle - } - - multi method load-precompilation-file(IO::Handle $file --> CompUnit::Handle:D) { - my $handle := CompUnit::Handle.new; - my $*CTXSAVE := $handle; - my %*COMPILING := nqp::hash(); -#?if moar - # Switch file handle to binary mode before passing it off to the VM, - # so we don't lose things hanging around in the decoder. - $file.encoding(Nil); - nqp::loadbytecodefh(nqp::getattr($file, IO::Handle, '$!PIO'), $file.path.Str); -#?endif - $handle - } - - # Load the specified byte buffer as if it was the contents of a - # precompiled file - method load-precompilation(Blob:D $bytes --> CompUnit::Handle:D) { - my $handle := CompUnit::Handle.new; - my $*CTXSAVE := $handle; - my %*COMPILING := nqp::hash(); - nqp::loadbytecodebuffer($bytes); - $handle - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Loader.pm6 rakudo-2018.03/src/core/CompUnit/Loader.pm6 --- rakudo-2018.02.1/src/core/CompUnit/Loader.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Loader.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,66 @@ +class CompUnit::Loader is repr('Uninstantiable') { + # Load a file from source and compile it + method load-source-file(IO::Path $path --> CompUnit::Handle) { + # Get the compiler and compile the code, then run it + # (which runs the mainline and captures UNIT). + my $?FILES := $path.Str; + self.load-source($path.slurp(:bin)) + } + + # Decode the specified byte buffer as source code, and compile it + method load-source(Blob:D $bytes --> CompUnit::Handle:D) { + my $preserve_global := nqp::ifnull(nqp::gethllsym('perl6', 'GLOBAL'), Mu); + + my $handle := CompUnit::Handle.new; + my $*CTXSAVE := $handle; + my $eval := nqp::getcomp('perl6').compile($bytes.decode); + + $eval(); + + nqp::bindhllsym('perl6', 'GLOBAL', $preserve_global); + + CATCH { + default { + nqp::bindhllsym('perl6', 'GLOBAL', $preserve_global); + .throw; + } + } + + $handle + } + + # Load a pre-compiled file + proto method load-precompilation-file(|) {*} + multi method load-precompilation-file(IO::Path $path --> CompUnit::Handle:D) { + my $handle := CompUnit::Handle.new; + my $*CTXSAVE := $handle; + my %*COMPILING := nqp::hash(); + nqp::loadbytecode($path.Str); + $handle + } + + multi method load-precompilation-file(IO::Handle $file --> CompUnit::Handle:D) { + my $handle := CompUnit::Handle.new; + my $*CTXSAVE := $handle; + my %*COMPILING := nqp::hash(); +#?if moar + # Switch file handle to binary mode before passing it off to the VM, + # so we don't lose things hanging around in the decoder. + $file.encoding(Nil); + nqp::loadbytecodefh(nqp::getattr($file, IO::Handle, '$!PIO'), $file.path.Str); +#?endif + $handle + } + + # Load the specified byte buffer as if it was the contents of a + # precompiled file + method load-precompilation(Blob:D $bytes --> CompUnit::Handle:D) { + my $handle := CompUnit::Handle.new; + my $*CTXSAVE := $handle; + my %*COMPILING := nqp::hash(); + nqp::loadbytecodebuffer($bytes); + $handle + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/PrecompilationRepository.pm rakudo-2018.03/src/core/CompUnit/PrecompilationRepository.pm --- rakudo-2018.02.1/src/core/CompUnit/PrecompilationRepository.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/PrecompilationRepository.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,331 +0,0 @@ -{ - role CompUnit::PrecompilationRepository { - method try-load( - CompUnit::PrecompilationDependency::File $dependency, - IO::Path :$source, - CompUnit::PrecompilationStore :@precomp-stores, - --> CompUnit::Handle:D) { - Nil - } - - method load(CompUnit::PrecompilationId $id --> Nil) { } - - method may-precomp(--> Bool:D) { - True # would be a good place to check an environment variable - } - } -} - -BEGIN CompUnit::PrecompilationRepository:: := CompUnit::PrecompilationRepository.new; - -class CompUnit { ... } -class CompUnit::PrecompilationRepository::Default does CompUnit::PrecompilationRepository { - has CompUnit::PrecompilationStore $.store; - my %loaded; - my $loaded-lock = Lock.new; - my $first-repo-id; - - my $lle; - my $profile; - my $optimize; - - method try-load( - CompUnit::PrecompilationDependency::File $dependency, - IO::Path :$source = $dependency.src.IO, - CompUnit::PrecompilationStore :@precomp-stores = Array[CompUnit::PrecompilationStore].new($.store), - --> CompUnit::Handle:D) { - my $RMD = $*RAKUDO_MODULE_DEBUG; - my $id = $dependency.id; - $RMD("try-load $id: $source") if $RMD; - - # Even if we may no longer precompile, we should use already loaded files - $loaded-lock.protect: { - return %loaded{$id} if %loaded{$id}:exists; - } - - my ($handle, $checksum) = ( - self.may-precomp and ( - my $loaded = self.load($id, :source($source), :checksum($dependency.checksum), :@precomp-stores) # already precompiled? - or self.precompile($source, $id, :source-name($dependency.source-name), :force($loaded ~~ Failure)) - and self.load($id, :@precomp-stores) # if not do it now - ) - ); - - if $*W and $*W.record_precompilation_dependencies { - if $handle { - $dependency.checksum = $checksum; - say $dependency.serialize; - } - else { - nqp::exit(0); - } - } - - $handle ?? $handle !! Nil - } - - method !load-handle-for-path(CompUnit::PrecompilationUnit $unit) { - my $preserve_global := nqp::ifnull(nqp::gethllsym('perl6', 'GLOBAL'), Mu); - if $*RAKUDO_MODULE_DEBUG -> $RMD { $RMD("Loading precompiled\n$unit") } -#?if moar - my $handle := CompUnit::Loader.load-precompilation-file($unit.bytecode-handle); - $unit.close; -#?endif -#?if !moar - my $handle := CompUnit::Loader.load-precompilation($unit.bytecode); -#?endif - nqp::bindhllsym('perl6', 'GLOBAL', $preserve_global); - CATCH { - default { - nqp::bindhllsym('perl6', 'GLOBAL', $preserve_global); - .throw; - } - } - $handle - } - - method !load-file( - CompUnit::PrecompilationStore @precomp-stores, - CompUnit::PrecompilationId $id, - :$repo-id, - ) { - my $compiler-id = CompUnit::PrecompilationId.new-without-check($*PERL.compiler.id); - my $RMD = $*RAKUDO_MODULE_DEBUG; - for @precomp-stores -> $store { - $RMD("Trying to load {$id ~ ($repo-id ?? '.repo-id' !! '')} from $store.prefix()") if $RMD; - my $file = $repo-id - ?? $store.load-repo-id($compiler-id, $id) - !! $store.load-unit($compiler-id, $id); - return $file if $file; - } - Nil - } - - method !load-dependencies(CompUnit::PrecompilationUnit:D $precomp-unit, @precomp-stores) { - my $compiler-id = CompUnit::PrecompilationId.new-without-check($*PERL.compiler.id); - my $RMD = $*RAKUDO_MODULE_DEBUG; - my $resolve = False; - my $repo = $*REPO; - $first-repo-id //= $repo.id; - my $repo-id = self!load-file(@precomp-stores, $precomp-unit.id, :repo-id); - if $repo-id ne $repo.id { - $RMD("Repo changed: $repo-id ne {$repo.id}. Need to re-check dependencies.") if $RMD; - $resolve = True; - } - if $repo-id ne $first-repo-id { - $RMD("Repo chain changed: $repo-id ne {$first-repo-id}. Need to re-check dependencies.") if $RMD; - $resolve = True; - } - $resolve = False unless %*ENV // 1; - my @dependencies; - for $precomp-unit.dependencies -> $dependency { - $RMD("dependency: $dependency") if $RMD; - - if $resolve { - my $comp-unit = $repo.resolve($dependency.spec); - $RMD("Old id: $dependency.id(), new id: {$comp-unit.repo-id}") if $RMD; - return False unless $comp-unit and $comp-unit.repo-id eq $dependency.id; - } - - my $dependency-precomp = @precomp-stores - .map({ $_.load-unit($compiler-id, $dependency.id) }) - .first(*.defined) - or do { - $RMD("Could not find $dependency.spec()") if $RMD; - return False; - } - unless $dependency-precomp.is-up-to-date($dependency, :check-source($resolve)) { - $dependency-precomp.close; - return False; - } - - @dependencies.push: $dependency-precomp; - } - - $loaded-lock.protect: { - for @dependencies -> $dependency-precomp { - unless %loaded{$dependency-precomp.id}:exists { - %loaded{$dependency-precomp.id} = self!load-handle-for-path($dependency-precomp); - } - } - } - - # report back id and source location of dependency to dependant - if $*W and $*W.record_precompilation_dependencies { - for $precomp-unit.dependencies -> $dependency { - say $dependency.serialize; - } - } - - if $resolve { - self.store.store-repo-id($compiler-id, $precomp-unit.id, :repo-id($repo.id)); - } - True - } - - proto method load(|) {*} - - multi method load( - Str $id, - Instant :$since, - IO::Path :$source, - CompUnit::PrecompilationStore :@precomp-stores = Array[CompUnit::PrecompilationStore].new($.store), - ) { - self.load(CompUnit::PrecompilationId.new($id), :$since, :@precomp-stores) - } - - multi method load( - CompUnit::PrecompilationId $id, - IO::Path :$source, - Str :$checksum is copy, - Instant :$since, - CompUnit::PrecompilationStore :@precomp-stores = Array[CompUnit::PrecompilationStore].new($.store), - ) { - $loaded-lock.protect: { - return %loaded{$id} if %loaded{$id}:exists; - } - my $RMD = $*RAKUDO_MODULE_DEBUG; - my $compiler-id = CompUnit::PrecompilationId.new-without-check($*PERL.compiler.id); - my $unit = self!load-file(@precomp-stores, $id); - if $unit { - if (not $since or $unit.modified > $since) - and (not $source or ($checksum //= nqp::sha1($source.slurp(:enc))) eq $unit.source-checksum) - and self!load-dependencies($unit, @precomp-stores) - { - my \loaded = self!load-handle-for-path($unit); - $loaded-lock.protect: { %loaded{$id} = loaded }; - return (loaded, $unit.checksum); - } - else { - $RMD("Outdated precompiled {$unit}{$source ?? " for $source" !! ''}\n" - ~ " mtime: {$unit.modified}{$since ?? ", since: $since" !! ''}\n" - ~ " checksum: {$unit.source-checksum}, expected: $checksum") if $RMD; - $unit.close; - fail "Outdated precompiled $unit"; - } - } - Nil - } - - proto method precompile(|) {*} - - multi method precompile( - IO::Path:D $path, - Str $id, - Bool :$force = False, - :$source-name = $path.Str - ) { - self.precompile($path, CompUnit::PrecompilationId.new($id), :$force, :$source-name) - } - - multi method precompile( - IO::Path:D $path, - CompUnit::PrecompilationId $id, - Bool :$force = False, - :$source-name = $path.Str - ) { - my $compiler-id = CompUnit::PrecompilationId.new-without-check($*PERL.compiler.id); - my $io = self.store.destination($compiler-id, $id); - return False unless $io; - my $RMD = $*RAKUDO_MODULE_DEBUG; - if not $force and $io.e and $io.s { - $RMD("$source-name\nalready precompiled into\n$io") if $RMD; - self.store.unlock; - return True; - } - my $source-checksum = nqp::sha1($path.slurp(:enc)); - my $bc = "$io.bc".IO; - - $lle //= Rakudo::Internals.LL-EXCEPTION; - $profile //= Rakudo::Internals.PROFILE; - $optimize //= Rakudo::Internals.OPTIMIZE; - my %env = %*ENV; # Local copy for us to tweak - %env = $*REPO.repo-chain.map(*.path-spec).join(','); - - my $rakudo_precomp_loading = %env; - my $modules = $rakudo_precomp_loading ?? Rakudo::Internals::JSON.from-json: $rakudo_precomp_loading !! []; - die "Circular module loading detected trying to precompile $path" if $modules.Set{$path.Str}:exists; - %env = Rakudo::Internals::JSON.to-json: [|$modules, $path.Str]; - %env = $*RESOURCES ?? $*RESOURCES.Str !! '{}'; - - $RMD("Precompiling $path into $bc ($lle $profile $optimize)") if $RMD; - my $perl6 = $*EXECUTABLE - .subst('perl6-debug', 'perl6') # debugger would try to precompile it's UI - .subst('perl6-gdb', 'perl6') - .subst('perl6-jdb-server', 'perl6-j') ; - if %env { - $perl6.subst-mutate('perl6-j', 'perl6-jdb-server'); - note "starting jdb on port " ~ ++%env; - } - my $out = ''; - my $err = ''; - my $status; - react { - my $proc = Proc::Async.new( - $perl6, - $lle, - $profile, - $optimize, - "--target=" ~ Rakudo::Internals.PRECOMP-TARGET, - "--output=$bc", - "--source-name=$source-name", - $path - ); - - whenever $proc.stdout { - $out ~= $_ - } - unless $RMD { - whenever $proc.stderr { - $err ~= $_ - } - } - whenever $proc.start(ENV => %env) { - $status = .exitcode - } - } - - my @result = $out.lines.unique; - if $status { # something wrong - self.store.unlock; - $RMD("Precompiling $path failed: $status") if $RMD; - Rakudo::Internals.VERBATIM-EXCEPTION(1); - die $RMD ?? @result !! $err; - } - - if not $RMD and $err -> $warnings { - $*ERR.print($warnings); - } - unless $bc.e { - $RMD("$path aborted precompilation without failure") if $RMD; - self.store.unlock; - return False; - } - $RMD("Precompiled $path into $bc") if $RMD; - my str $dependencies = ''; - my CompUnit::PrecompilationDependency::File @dependencies; - my %dependencies; - for @result -> $dependency-str { - unless $dependency-str ~~ /^<[A..Z0..9]> ** 40 \0 .+/ { - say $dependency-str; - next - } - my $dependency = CompUnit::PrecompilationDependency::File.deserialize($dependency-str); - next if %dependencies{$dependency.Str}++; # already got that one - $RMD($dependency.Str()) if $RMD; - @dependencies.push: $dependency; - } - $RMD("Writing dependencies and byte code to $io.tmp for source checksum: $source-checksum") if $RMD; - self.store.store-unit( - $compiler-id, - $id, - self.store.new-unit(:$id, :@dependencies, :$source-checksum, :bytecode($bc.slurp(:bin))), - ); - $bc.unlink; - self.store.store-repo-id($compiler-id, $id, :repo-id($*REPO.id)); - self.store.unlock; - True - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/PrecompilationRepository.pm6 rakudo-2018.03/src/core/CompUnit/PrecompilationRepository.pm6 --- rakudo-2018.02.1/src/core/CompUnit/PrecompilationRepository.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/PrecompilationRepository.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,331 @@ +{ + role CompUnit::PrecompilationRepository { + method try-load( + CompUnit::PrecompilationDependency::File $dependency, + IO::Path :$source, + CompUnit::PrecompilationStore :@precomp-stores, + --> CompUnit::Handle:D) { + Nil + } + + method load(CompUnit::PrecompilationId $id --> Nil) { } + + method may-precomp(--> Bool:D) { + True # would be a good place to check an environment variable + } + } +} + +BEGIN CompUnit::PrecompilationRepository:: := CompUnit::PrecompilationRepository.new; + +class CompUnit { ... } +class CompUnit::PrecompilationRepository::Default does CompUnit::PrecompilationRepository { + has CompUnit::PrecompilationStore $.store; + my %loaded; + my $loaded-lock = Lock.new; + my $first-repo-id; + + my $lle; + my $profile; + my $optimize; + + method try-load( + CompUnit::PrecompilationDependency::File $dependency, + IO::Path :$source = $dependency.src.IO, + CompUnit::PrecompilationStore :@precomp-stores = Array[CompUnit::PrecompilationStore].new($.store), + --> CompUnit::Handle:D) { + my $RMD = $*RAKUDO_MODULE_DEBUG; + my $id = $dependency.id; + $RMD("try-load $id: $source") if $RMD; + + # Even if we may no longer precompile, we should use already loaded files + $loaded-lock.protect: { + return %loaded{$id} if %loaded{$id}:exists; + } + + my ($handle, $checksum) = ( + self.may-precomp and ( + my $loaded = self.load($id, :source($source), :checksum($dependency.checksum), :@precomp-stores) # already precompiled? + or self.precompile($source, $id, :source-name($dependency.source-name), :force($loaded ~~ Failure)) + and self.load($id, :@precomp-stores) # if not do it now + ) + ); + + if $*W and $*W.record_precompilation_dependencies { + if $handle { + $dependency.checksum = $checksum; + say $dependency.serialize; + } + else { + nqp::exit(0); + } + } + + $handle ?? $handle !! Nil + } + + method !load-handle-for-path(CompUnit::PrecompilationUnit $unit) { + my $preserve_global := nqp::ifnull(nqp::gethllsym('perl6', 'GLOBAL'), Mu); + if $*RAKUDO_MODULE_DEBUG -> $RMD { $RMD("Loading precompiled\n$unit") } +#?if moar + my $handle := CompUnit::Loader.load-precompilation-file($unit.bytecode-handle); + $unit.close; +#?endif +#?if !moar + my $handle := CompUnit::Loader.load-precompilation($unit.bytecode); +#?endif + nqp::bindhllsym('perl6', 'GLOBAL', $preserve_global); + CATCH { + default { + nqp::bindhllsym('perl6', 'GLOBAL', $preserve_global); + .throw; + } + } + $handle + } + + method !load-file( + CompUnit::PrecompilationStore @precomp-stores, + CompUnit::PrecompilationId $id, + :$repo-id, + ) { + my $compiler-id = CompUnit::PrecompilationId.new-without-check($*PERL.compiler.id); + my $RMD = $*RAKUDO_MODULE_DEBUG; + for @precomp-stores -> $store { + $RMD("Trying to load {$id ~ ($repo-id ?? '.repo-id' !! '')} from $store.prefix()") if $RMD; + my $file = $repo-id + ?? $store.load-repo-id($compiler-id, $id) + !! $store.load-unit($compiler-id, $id); + return $file if $file; + } + Nil + } + + method !load-dependencies(CompUnit::PrecompilationUnit:D $precomp-unit, @precomp-stores) { + my $compiler-id = CompUnit::PrecompilationId.new-without-check($*PERL.compiler.id); + my $RMD = $*RAKUDO_MODULE_DEBUG; + my $resolve = False; + my $repo = $*REPO; + $first-repo-id //= $repo.id; + my $repo-id = self!load-file(@precomp-stores, $precomp-unit.id, :repo-id); + if $repo-id ne $repo.id { + $RMD("Repo changed: $repo-id ne {$repo.id}. Need to re-check dependencies.") if $RMD; + $resolve = True; + } + if $repo-id ne $first-repo-id { + $RMD("Repo chain changed: $repo-id ne {$first-repo-id}. Need to re-check dependencies.") if $RMD; + $resolve = True; + } + $resolve = False unless %*ENV // 1; + my @dependencies; + for $precomp-unit.dependencies -> $dependency { + $RMD("dependency: $dependency") if $RMD; + + if $resolve { + my $comp-unit = $repo.resolve($dependency.spec); + $RMD("Old id: $dependency.id(), new id: {$comp-unit.repo-id}") if $RMD; + return False unless $comp-unit and $comp-unit.repo-id eq $dependency.id; + } + + my $dependency-precomp = @precomp-stores + .map({ $_.load-unit($compiler-id, $dependency.id) }) + .first(*.defined) + or do { + $RMD("Could not find $dependency.spec()") if $RMD; + return False; + } + unless $dependency-precomp.is-up-to-date($dependency, :check-source($resolve)) { + $dependency-precomp.close; + return False; + } + + @dependencies.push: $dependency-precomp; + } + + $loaded-lock.protect: { + for @dependencies -> $dependency-precomp { + unless %loaded{$dependency-precomp.id}:exists { + %loaded{$dependency-precomp.id} = self!load-handle-for-path($dependency-precomp); + } + } + } + + # report back id and source location of dependency to dependant + if $*W and $*W.record_precompilation_dependencies { + for $precomp-unit.dependencies -> $dependency { + say $dependency.serialize; + } + } + + if $resolve { + self.store.store-repo-id($compiler-id, $precomp-unit.id, :repo-id($repo.id)); + } + True + } + + proto method load(|) {*} + + multi method load( + Str $id, + Instant :$since, + IO::Path :$source, + CompUnit::PrecompilationStore :@precomp-stores = Array[CompUnit::PrecompilationStore].new($.store), + ) { + self.load(CompUnit::PrecompilationId.new($id), :$since, :@precomp-stores) + } + + multi method load( + CompUnit::PrecompilationId $id, + IO::Path :$source, + Str :$checksum is copy, + Instant :$since, + CompUnit::PrecompilationStore :@precomp-stores = Array[CompUnit::PrecompilationStore].new($.store), + ) { + $loaded-lock.protect: { + return %loaded{$id} if %loaded{$id}:exists; + } + my $RMD = $*RAKUDO_MODULE_DEBUG; + my $compiler-id = CompUnit::PrecompilationId.new-without-check($*PERL.compiler.id); + my $unit = self!load-file(@precomp-stores, $id); + if $unit { + if (not $since or $unit.modified > $since) + and (not $source or ($checksum //= nqp::sha1($source.slurp(:enc))) eq $unit.source-checksum) + and self!load-dependencies($unit, @precomp-stores) + { + my \loaded = self!load-handle-for-path($unit); + $loaded-lock.protect: { %loaded{$id} = loaded }; + return (loaded, $unit.checksum); + } + else { + $RMD("Outdated precompiled {$unit}{$source ?? " for $source" !! ''}\n" + ~ " mtime: {$unit.modified}{$since ?? ", since: $since" !! ''}\n" + ~ " checksum: {$unit.source-checksum}, expected: $checksum") if $RMD; + $unit.close; + fail "Outdated precompiled $unit"; + } + } + Nil + } + + proto method precompile(|) {*} + + multi method precompile( + IO::Path:D $path, + Str $id, + Bool :$force = False, + :$source-name = $path.Str + ) { + self.precompile($path, CompUnit::PrecompilationId.new($id), :$force, :$source-name) + } + + multi method precompile( + IO::Path:D $path, + CompUnit::PrecompilationId $id, + Bool :$force = False, + :$source-name = $path.Str + ) { + my $compiler-id = CompUnit::PrecompilationId.new-without-check($*PERL.compiler.id); + my $io = self.store.destination($compiler-id, $id); + return False unless $io; + my $RMD = $*RAKUDO_MODULE_DEBUG; + if not $force and $io.e and $io.s { + $RMD("$source-name\nalready precompiled into\n$io") if $RMD; + self.store.unlock; + return True; + } + my $source-checksum = nqp::sha1($path.slurp(:enc)); + my $bc = "$io.bc".IO; + + $lle //= Rakudo::Internals.LL-EXCEPTION; + $profile //= Rakudo::Internals.PROFILE; + $optimize //= Rakudo::Internals.OPTIMIZE; + my %env = %*ENV; # Local copy for us to tweak + %env = $*REPO.repo-chain.map(*.path-spec).join(','); + + my $rakudo_precomp_loading = %env; + my $modules = $rakudo_precomp_loading ?? Rakudo::Internals::JSON.from-json: $rakudo_precomp_loading !! []; + die "Circular module loading detected trying to precompile $path" if $modules.Set{$path.Str}:exists; + %env = Rakudo::Internals::JSON.to-json: [|$modules, $path.Str]; + %env = $*RESOURCES ?? $*RESOURCES.Str !! '{}'; + + $RMD("Precompiling $path into $bc ($lle $profile $optimize)") if $RMD; + my $perl6 = $*EXECUTABLE + .subst('perl6-debug', 'perl6') # debugger would try to precompile it's UI + .subst('perl6-gdb', 'perl6') + .subst('perl6-jdb-server', 'perl6-j') ; + if %env { + $perl6.subst-mutate('perl6-j', 'perl6-jdb-server'); + note "starting jdb on port " ~ ++%env; + } + my $out = ''; + my $err = ''; + my $status; + react { + my $proc = Proc::Async.new( + $perl6, + $lle, + $profile, + $optimize, + "--target=" ~ Rakudo::Internals.PRECOMP-TARGET, + "--output=$bc", + "--source-name=$source-name", + $path + ); + + whenever $proc.stdout { + $out ~= $_ + } + unless $RMD { + whenever $proc.stderr { + $err ~= $_ + } + } + whenever $proc.start(ENV => %env) { + $status = .exitcode + } + } + + my @result = $out.lines.unique; + if $status { # something wrong + self.store.unlock; + $RMD("Precompiling $path failed: $status") if $RMD; + Rakudo::Internals.VERBATIM-EXCEPTION(1); + die $RMD ?? @result !! $err; + } + + if not $RMD and $err -> $warnings { + $*ERR.print($warnings); + } + unless $bc.e { + $RMD("$path aborted precompilation without failure") if $RMD; + self.store.unlock; + return False; + } + $RMD("Precompiled $path into $bc") if $RMD; + my str $dependencies = ''; + my CompUnit::PrecompilationDependency::File @dependencies; + my %dependencies; + for @result -> $dependency-str { + unless $dependency-str ~~ /^<[A..Z0..9]> ** 40 \0 .+/ { + say $dependency-str; + next + } + my $dependency = CompUnit::PrecompilationDependency::File.deserialize($dependency-str); + next if %dependencies{$dependency.Str}++; # already got that one + $RMD($dependency.Str()) if $RMD; + @dependencies.push: $dependency; + } + $RMD("Writing dependencies and byte code to $io.tmp for source checksum: $source-checksum") if $RMD; + self.store.store-unit( + $compiler-id, + $id, + self.store.new-unit(:$id, :@dependencies, :$source-checksum, :bytecode($bc.slurp(:bin))), + ); + $bc.unlink; + self.store.store-repo-id($compiler-id, $id, :repo-id($*REPO.id)); + self.store.unlock; + True + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/PrecompilationStore/File.pm rakudo-2018.03/src/core/CompUnit/PrecompilationStore/File.pm --- rakudo-2018.02.1/src/core/CompUnit/PrecompilationStore/File.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/PrecompilationStore/File.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,256 +0,0 @@ -class CompUnit::PrecompilationStore::File does CompUnit::PrecompilationStore { - my class CompUnit::PrecompilationUnit::File does CompUnit::PrecompilationUnit { - has CompUnit::PrecompilationId $.id; - has IO::Path $.path; - has IO::Handle $!file; - has CompUnit::PrecompilationDependency @!dependencies; - has $!initialized = False; - has $.checksum; - has $.source-checksum; - has $!bytecode; - has $!store; - has Lock $!update-lock = Lock.new; - - submethod BUILD( - CompUnit::PrecompilationId :$!id, - IO::Path :$!path, - :$!source-checksum, - :@!dependencies, - :$!bytecode, - :$!store, - --> Nil - ) { - if $!bytecode { - $!initialized = True; - $!checksum = nqp::sha1($!bytecode.decode('iso-8859-1')); - } - } - - method !open() { - $!file = $!path.open(:r); - } - - method modified(--> Instant:D) { - $!path.modified - } - - method !read-dependencies() { - $!update-lock.protect: { - return if $!initialized; - self!open(:r) unless $!file; - - $!checksum = $!file.get; - $!source-checksum = $!file.get; - my $dependency = $!file.get; - while $dependency { - @!dependencies.push: CompUnit::PrecompilationDependency::File.deserialize($dependency); - $dependency = $!file.get; - } - $!initialized = True; - } - } - - method dependencies(--> Array[CompUnit::PrecompilationDependency]) { - self!read-dependencies; - @!dependencies - } - - method bytecode(--> Buf:D) { - $!update-lock.protect: { - self!read-dependencies; - $!bytecode //= $!file.slurp-rest(:bin,:close) - } - } - - method bytecode-handle(--> IO::Handle:D) { - self!read-dependencies; - $!file - } - - method source-checksum() is rw { - self!read-dependencies; - $!source-checksum - } - - method checksum() is rw { - self!read-dependencies; - $!checksum - } - - method Str(--> Str:D) { - self.path.Str - } - - method close(--> Nil) { - $!update-lock.protect: { - $!file.close if $!file; - $!file = Nil; - } - } - - method save-to(IO::Path $precomp-file) { - my $handle = $precomp-file.open(:w); - $handle.print($!checksum ~ "\n"); - $handle.print($!source-checksum ~ "\n"); - $handle.print($_.serialize ~ "\n") for @!dependencies; - $handle.print("\n"); - $handle.write($!bytecode); - $handle.close; - $!path = $precomp-file; - } - - method is-up-to-date(CompUnit::PrecompilationDependency $dependency, Bool :$check-source --> Bool) { - my $result = self.CompUnit::PrecompilationUnit::is-up-to-date($dependency, :$check-source); - $!store.remove-from-cache($.id) unless $result; - $result - } - } - - has IO::Path $.prefix is required; - has IO::Handle $!lock; - has int $!lock-count = 0; - has %!loaded; - has %!compiler-cache; - has %!dir-cache; - has Lock $!update-lock = Lock.new; - - submethod BUILD(IO::Path :$!prefix --> Nil) { - } - - method new-unit(|c) { - CompUnit::PrecompilationUnit::File.new(|c, :store(self)) - } - - method !dir(CompUnit::PrecompilationId $compiler-id, - CompUnit::PrecompilationId $precomp-id) - { - $!update-lock.protect: { - %!dir-cache{$compiler-id ~ $precomp-id} //= - (%!compiler-cache{$compiler-id} //= self.prefix.add($compiler-id)) - .add($precomp-id.substr(0, 2)) - } - } - - method path(CompUnit::PrecompilationId $compiler-id, - CompUnit::PrecompilationId $precomp-id, - Str :$extension = '') - { - self!dir($compiler-id, $precomp-id).add($precomp-id ~ $extension) - } - - method !lock(--> Nil) { - return if $*W && $*W.is_precompilation_mode(); - $!update-lock.lock; - $!lock //= $.prefix.add('.lock').open(:create, :rw); - $!lock.lock if $!lock-count++ == 0; - } - - method unlock() { - return if $*W && $*W.is_precompilation_mode(); - { - LEAVE $!update-lock.unlock; - die "unlock when we're not locked!" if $!lock-count == 0; - $!lock-count-- if $!lock-count > 0; - $!lock && $!lock-count == 0 ?? $!lock.unlock !! True - } - } - - method load-unit(CompUnit::PrecompilationId $compiler-id, - CompUnit::PrecompilationId $precomp-id) - { - $!update-lock.protect: { - %!loaded{$precomp-id} //= do { - my $path = self.path($compiler-id, $precomp-id); - $path ~~ :e - ?? CompUnit::PrecompilationUnit::File.new(:id($precomp-id), :$path, :store(self)) - !! Nil - } - } - } - - method load-repo-id(CompUnit::PrecompilationId $compiler-id, - CompUnit::PrecompilationId $precomp-id) - { - my $path = self.path($compiler-id, $precomp-id, :extension<.repo-id>); - if $path ~~ :e { - $path.slurp - } - else { - Nil - } - } - - method remove-from-cache(CompUnit::PrecompilationId $precomp-id) { - $!update-lock.protect: { %!loaded{$precomp-id}:delete }; - } - - method destination(CompUnit::PrecompilationId $compiler-id, - CompUnit::PrecompilationId $precomp-id, - Str :$extension = '' - --> IO::Path:D) - { - unless $!prefix.e { - $!prefix.mkdir or return; - } - return unless $!prefix.w; - self!lock(); - self!file($compiler-id, $precomp-id, :$extension); - } - - method !file(CompUnit::PrecompilationId $compiler-id, - CompUnit::PrecompilationId $precomp-id, - Str :$extension = '' - --> IO::Path:D) - { - my $compiler-dir = self.prefix.add($compiler-id); - $compiler-dir.mkdir unless $compiler-dir.e; - my $dest = self!dir($compiler-id, $precomp-id); - $dest.mkdir unless $dest.e; - $dest.add($precomp-id ~ $extension) - } - - method store-file(CompUnit::PrecompilationId $compiler-id, - CompUnit::PrecompilationId $precomp-id, - IO::Path:D $path, - :$extension = '') - { - $path.rename(self!file($compiler-id, $precomp-id, :$extension)); - } - - method store-unit(CompUnit::PrecompilationId $compiler-id, - CompUnit::PrecompilationId $precomp-id, - CompUnit::PrecompilationUnit $unit) - { - my $precomp-file = self!file($compiler-id, $precomp-id, :extension<.tmp>); - $unit.save-to($precomp-file); - $precomp-file.rename(self!file($compiler-id, $precomp-id)); - self.remove-from-cache($precomp-id); - } - - method store-repo-id(CompUnit::PrecompilationId $compiler-id, - CompUnit::PrecompilationId $precomp-id, - :$repo-id!) - { - try self!file($compiler-id, $precomp-id, :extension<.repo-id>).spurt($repo-id); - } - - method delete( - CompUnit::PrecompilationId $compiler-id, - CompUnit::PrecompilationId $precomp-id, - Str :$extension = '') - { - self.path($compiler-id, $precomp-id, :$extension).unlink; - } - - method delete-by-compiler(CompUnit::PrecompilationId $compiler-id) - { - my $compiler-dir = self.prefix.add($compiler-id); - for $compiler-dir.dir -> $subdir { - $subdir.dir>>.unlink; - $subdir.rmdir; - } - $compiler-dir.rmdir; - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/PrecompilationStore/File.pm6 rakudo-2018.03/src/core/CompUnit/PrecompilationStore/File.pm6 --- rakudo-2018.02.1/src/core/CompUnit/PrecompilationStore/File.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/PrecompilationStore/File.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,256 @@ +class CompUnit::PrecompilationStore::File does CompUnit::PrecompilationStore { + my class CompUnit::PrecompilationUnit::File does CompUnit::PrecompilationUnit { + has CompUnit::PrecompilationId $.id; + has IO::Path $.path; + has IO::Handle $!file; + has CompUnit::PrecompilationDependency @!dependencies; + has $!initialized = False; + has $.checksum; + has $.source-checksum; + has $!bytecode; + has $!store; + has Lock $!update-lock = Lock.new; + + submethod BUILD( + CompUnit::PrecompilationId :$!id, + IO::Path :$!path, + :$!source-checksum, + :@!dependencies, + :$!bytecode, + :$!store, + --> Nil + ) { + if $!bytecode { + $!initialized = True; + $!checksum = nqp::sha1($!bytecode.decode('iso-8859-1')); + } + } + + method !open() { + $!file = $!path.open(:r); + } + + method modified(--> Instant:D) { + $!path.modified + } + + method !read-dependencies() { + $!update-lock.protect: { + return if $!initialized; + self!open(:r) unless $!file; + + $!checksum = $!file.get; + $!source-checksum = $!file.get; + my $dependency = $!file.get; + while $dependency { + @!dependencies.push: CompUnit::PrecompilationDependency::File.deserialize($dependency); + $dependency = $!file.get; + } + $!initialized = True; + } + } + + method dependencies(--> Array[CompUnit::PrecompilationDependency]) { + self!read-dependencies; + @!dependencies + } + + method bytecode(--> Buf:D) { + $!update-lock.protect: { + self!read-dependencies; + $!bytecode //= $!file.slurp-rest(:bin,:close) + } + } + + method bytecode-handle(--> IO::Handle:D) { + self!read-dependencies; + $!file + } + + method source-checksum() is rw { + self!read-dependencies; + $!source-checksum + } + + method checksum() is rw { + self!read-dependencies; + $!checksum + } + + method Str(--> Str:D) { + self.path.Str + } + + method close(--> Nil) { + $!update-lock.protect: { + $!file.close if $!file; + $!file = Nil; + } + } + + method save-to(IO::Path $precomp-file) { + my $handle = $precomp-file.open(:w); + $handle.print($!checksum ~ "\n"); + $handle.print($!source-checksum ~ "\n"); + $handle.print($_.serialize ~ "\n") for @!dependencies; + $handle.print("\n"); + $handle.write($!bytecode); + $handle.close; + $!path = $precomp-file; + } + + method is-up-to-date(CompUnit::PrecompilationDependency $dependency, Bool :$check-source --> Bool) { + my $result = self.CompUnit::PrecompilationUnit::is-up-to-date($dependency, :$check-source); + $!store.remove-from-cache($.id) unless $result; + $result + } + } + + has IO::Path $.prefix is required; + has IO::Handle $!lock; + has int $!lock-count = 0; + has %!loaded; + has %!compiler-cache; + has %!dir-cache; + has Lock $!update-lock = Lock.new; + + submethod BUILD(IO::Path :$!prefix --> Nil) { + } + + method new-unit(|c) { + CompUnit::PrecompilationUnit::File.new(|c, :store(self)) + } + + method !dir(CompUnit::PrecompilationId $compiler-id, + CompUnit::PrecompilationId $precomp-id) + { + $!update-lock.protect: { + %!dir-cache{$compiler-id ~ $precomp-id} //= + (%!compiler-cache{$compiler-id} //= self.prefix.add($compiler-id)) + .add($precomp-id.substr(0, 2)) + } + } + + method path(CompUnit::PrecompilationId $compiler-id, + CompUnit::PrecompilationId $precomp-id, + Str :$extension = '') + { + self!dir($compiler-id, $precomp-id).add($precomp-id ~ $extension) + } + + method !lock(--> Nil) { + return if $*W && $*W.is_precompilation_mode(); + $!update-lock.lock; + $!lock //= $.prefix.add('.lock').open(:create, :rw); + $!lock.lock if $!lock-count++ == 0; + } + + method unlock() { + return if $*W && $*W.is_precompilation_mode(); + { + LEAVE $!update-lock.unlock; + die "unlock when we're not locked!" if $!lock-count == 0; + $!lock-count-- if $!lock-count > 0; + $!lock && $!lock-count == 0 ?? $!lock.unlock !! True + } + } + + method load-unit(CompUnit::PrecompilationId $compiler-id, + CompUnit::PrecompilationId $precomp-id) + { + $!update-lock.protect: { + %!loaded{$precomp-id} //= do { + my $path = self.path($compiler-id, $precomp-id); + $path ~~ :e + ?? CompUnit::PrecompilationUnit::File.new(:id($precomp-id), :$path, :store(self)) + !! Nil + } + } + } + + method load-repo-id(CompUnit::PrecompilationId $compiler-id, + CompUnit::PrecompilationId $precomp-id) + { + my $path = self.path($compiler-id, $precomp-id, :extension<.repo-id>); + if $path ~~ :e { + $path.slurp + } + else { + Nil + } + } + + method remove-from-cache(CompUnit::PrecompilationId $precomp-id) { + $!update-lock.protect: { %!loaded{$precomp-id}:delete }; + } + + method destination(CompUnit::PrecompilationId $compiler-id, + CompUnit::PrecompilationId $precomp-id, + Str :$extension = '' + --> IO::Path:D) + { + unless $!prefix.e { + $!prefix.mkdir or return; + } + return unless $!prefix.w; + self!lock(); + self!file($compiler-id, $precomp-id, :$extension); + } + + method !file(CompUnit::PrecompilationId $compiler-id, + CompUnit::PrecompilationId $precomp-id, + Str :$extension = '' + --> IO::Path:D) + { + my $compiler-dir = self.prefix.add($compiler-id); + $compiler-dir.mkdir unless $compiler-dir.e; + my $dest = self!dir($compiler-id, $precomp-id); + $dest.mkdir unless $dest.e; + $dest.add($precomp-id ~ $extension) + } + + method store-file(CompUnit::PrecompilationId $compiler-id, + CompUnit::PrecompilationId $precomp-id, + IO::Path:D $path, + :$extension = '') + { + $path.rename(self!file($compiler-id, $precomp-id, :$extension)); + } + + method store-unit(CompUnit::PrecompilationId $compiler-id, + CompUnit::PrecompilationId $precomp-id, + CompUnit::PrecompilationUnit $unit) + { + my $precomp-file = self!file($compiler-id, $precomp-id, :extension<.tmp>); + $unit.save-to($precomp-file); + $precomp-file.rename(self!file($compiler-id, $precomp-id)); + self.remove-from-cache($precomp-id); + } + + method store-repo-id(CompUnit::PrecompilationId $compiler-id, + CompUnit::PrecompilationId $precomp-id, + :$repo-id!) + { + try self!file($compiler-id, $precomp-id, :extension<.repo-id>).spurt($repo-id); + } + + method delete( + CompUnit::PrecompilationId $compiler-id, + CompUnit::PrecompilationId $precomp-id, + Str :$extension = '') + { + self.path($compiler-id, $precomp-id, :$extension).unlink; + } + + method delete-by-compiler(CompUnit::PrecompilationId $compiler-id) + { + my $compiler-dir = self.prefix.add($compiler-id); + for $compiler-dir.dir -> $subdir { + $subdir.dir>>.unlink; + $subdir.rmdir; + } + $compiler-dir.rmdir; + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/PrecompilationStore.pm rakudo-2018.03/src/core/CompUnit/PrecompilationStore.pm --- rakudo-2018.02.1/src/core/CompUnit/PrecompilationStore.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/PrecompilationStore.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,50 +0,0 @@ -role CompUnit::PrecompilationStore { - # Prepare a new implementation specific PrecompilationUnit for storage - method new-unit(| --> CompUnit::PrecompilationUnit:D) - { ... } - - # Load the precompilation identified by the pairing of the specified - # compiler and precompilation ID. - method load-unit(CompUnit::PrecompilationId $compiler-id, - CompUnit::PrecompilationId $precomp-id) - { ... } - - # Return the repository id for which the specified precomp file's - # dependencies have been validated - method load-repo-id(CompUnit::PrecompilationId $compiler-id, - CompUnit::PrecompilationId $precomp-id) - { ... } - - # Store the file at the specified path in the precompilation store, - # under the given compiler ID and precompilation ID. - method store-file(CompUnit::PrecompilationId $compiler-id, - CompUnit::PrecompilationId $precomp-id, - IO::Path:D $path, - :$extension = '') - { ... } - - # Store the given precompilation unit in the precompilation store - # under the given compiler ID and precompilation ID. - method store-unit(CompUnit::PrecompilationId $compiler-id, - CompUnit::PrecompilationId $precomp-id, - CompUnit::PrecompilationUnit $unit) - { ... } - - # Store the given repo-id for a precompilation under the given - # compiler ID and precompilation ID. - method store-repo-id(CompUnit::PrecompilationId $compiler-id, - CompUnit::PrecompilationId $precomp-id, - :$repo-id!) - { ... } - - # Delete an individual precompilation. - method delete(CompUnit::PrecompilationId $compiler-id, - CompUnit::PrecompilationId $precomp-id) - { ... } - - # Delete all precompilations for a particular compiler. - method delete-by-compiler(CompUnit::PrecompilationId $compiler-id) - { ... } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/PrecompilationStore.pm6 rakudo-2018.03/src/core/CompUnit/PrecompilationStore.pm6 --- rakudo-2018.02.1/src/core/CompUnit/PrecompilationStore.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/PrecompilationStore.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,50 @@ +role CompUnit::PrecompilationStore { + # Prepare a new implementation specific PrecompilationUnit for storage + method new-unit(| --> CompUnit::PrecompilationUnit:D) + { ... } + + # Load the precompilation identified by the pairing of the specified + # compiler and precompilation ID. + method load-unit(CompUnit::PrecompilationId $compiler-id, + CompUnit::PrecompilationId $precomp-id) + { ... } + + # Return the repository id for which the specified precomp file's + # dependencies have been validated + method load-repo-id(CompUnit::PrecompilationId $compiler-id, + CompUnit::PrecompilationId $precomp-id) + { ... } + + # Store the file at the specified path in the precompilation store, + # under the given compiler ID and precompilation ID. + method store-file(CompUnit::PrecompilationId $compiler-id, + CompUnit::PrecompilationId $precomp-id, + IO::Path:D $path, + :$extension = '') + { ... } + + # Store the given precompilation unit in the precompilation store + # under the given compiler ID and precompilation ID. + method store-unit(CompUnit::PrecompilationId $compiler-id, + CompUnit::PrecompilationId $precomp-id, + CompUnit::PrecompilationUnit $unit) + { ... } + + # Store the given repo-id for a precompilation under the given + # compiler ID and precompilation ID. + method store-repo-id(CompUnit::PrecompilationId $compiler-id, + CompUnit::PrecompilationId $precomp-id, + :$repo-id!) + { ... } + + # Delete an individual precompilation. + method delete(CompUnit::PrecompilationId $compiler-id, + CompUnit::PrecompilationId $precomp-id) + { ... } + + # Delete all precompilations for a particular compiler. + method delete-by-compiler(CompUnit::PrecompilationId $compiler-id) + { ... } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/PrecompilationUnit.pm rakudo-2018.03/src/core/CompUnit/PrecompilationUnit.pm --- rakudo-2018.02.1/src/core/CompUnit/PrecompilationUnit.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/PrecompilationUnit.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,139 +0,0 @@ -class CompUnit::PrecompilationId { - has $.id; - - my $cache-lock = Lock.new; - my %cache; - - method new(Str:D $id) { - $cache-lock.protect: { - %cache{$id} //= 2 < $id.chars < 64 && $id ~~ /^<[A..Za..z0..9._-]>+$/ - ?? self.bless(:$id) - !! die "Invalid precompilation id: $id" - } - } - - method new-from-string(Str:D $id) { - $cache-lock.protect: { - %cache{$id} //= self.bless(:id(nqp::sha1($id))) - } - } - - method new-without-check(Str:D $id) { - $cache-lock.protect: { - %cache{$id} //= self.bless(:id($id)) - } - } - - method Str() { $!id } - method IO() { $!id.IO } - method substr(|c) { $!id.substr(|c) } -} - -role CompUnit::PrecompilationDependency { - method id(--> CompUnit::PrecompilationId:D) { ... } - method src(--> Str:D) { ... } - method spec(--> CompUnit::DependencySpecification:D) { ... } - method checksum(--> Str:D) { ... } - method Str() { - "$.id $.src $.spec" - } - method serialize(--> Str:D) { ... } - method deserialize(Str, --> CompUnit::PrecompilationDependency:D) { ... } -} - -role CompUnit::PrecompilationUnit { - method id(--> CompUnit::PrecompilationId:D) { ... } - method path(--> IO::Path:D) { ... } - method modified(--> Instant:D) { ... } - method dependencies(--> Array[CompUnit::PrecompilationDependency]) { ... } - method bytecode(--> Buf:D) { ... } - method checksum(--> Str:D) { ... } - method source-checksum(--> Str:D) { ... } - method bytecode-handle(--> IO::Handle:D) { ... } - method close(--> Nil) { ... } - method is-up-to-date(CompUnit::PrecompilationDependency $dependency, Bool :$check-source --> Bool) { - my $RMD = $*RAKUDO_MODULE_DEBUG; - if $check-source { # a repo changed, so maybe it's a change in our source file - my $source-checksum = $.source-checksum; - - my $srcIO = CompUnit::RepositoryRegistry.file-for-spec($dependency.src) // $dependency.src.IO; - unless $srcIO { - return False unless $srcIO.e; - } - my $current-source-checksum := nqp::sha1($srcIO.slurp(:enc)); - $RMD( - "$.path\nspec: $dependency.spec()\nsource: $srcIO\n" - ~ "source-checksum: $source-checksum\ncurrent-source-checksum: $current-source-checksum" - ) if $RMD; - return False if $source-checksum ne $current-source-checksum; - } - - $RMD("dependency checksum $dependency.checksum() unit: $.checksum()") if $RMD; - - $.checksum eq $dependency.checksum - } -} - -class CompUnit::PrecompilationDependency::File does CompUnit::PrecompilationDependency { - has CompUnit::PrecompilationId $.id; - has Str $.src; - has Str $.checksum is rw; - has Str $!serialized-spec; - has CompUnit::DependencySpecification $.spec; - - method source-name() { - "$.src ($.spec.short-name())" - } - - method deserialize(str $str) { - my $parts := nqp::split("\0", $str); - nqp::p6bindattrinvres( - self.new( - :id(CompUnit::PrecompilationId.new-without-check(nqp::atpos($parts, 0))), - :src(nqp::atpos($parts, 1)), - :checksum(nqp::atpos($parts, 2)) - ), - CompUnit::PrecompilationDependency::File, - '$!serialized-spec', - nqp::atpos($parts, 3), - ); - } - - method spec(--> CompUnit::DependencySpecification:D) { - $!spec //= $!serialized-spec - ?? do { -#?if jvm - my @spec = $!serialized-spec.split("\0", 3); - my @spec-pairs; - for @spec>>.match(/(<-[:]>+)':'(.+)/) { - @spec-pairs.push: .[0].Str => (.[1] ~~ / ^ \d+ $ / ?? .[1].Int !! .[1].Str); - } - CompUnit::DependencySpecification.new: |%(|@spec-pairs); -#?endif -#?if moar - use MONKEY-SEE-NO-EVAL; - EVAL $!serialized-spec; -#?endif - } - !! Nil; - } - - method serialize(--> Str:D) { -#?if jvm - my $specs; - for $.spec.^attributes { - $specs ~= .name.substr(2) ~ ":" ~ $.spec."$(.name.substr(2))"() ~ "\0"; - } - "$.id\0$.src\0$.checksum\0$specs" -#?endif -#?if !jvm - "$.id\0$.src\0$.checksum\0{$!serialized-spec ?? $!serialized-spec !! $!spec.perl}" -#?endif - } - - method Str() { - "$.id $.src $.checksum {$!serialized-spec ?? $!serialized-spec !! $!spec.perl}" - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/PrecompilationUnit.pm6 rakudo-2018.03/src/core/CompUnit/PrecompilationUnit.pm6 --- rakudo-2018.02.1/src/core/CompUnit/PrecompilationUnit.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/PrecompilationUnit.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,139 @@ +class CompUnit::PrecompilationId { + has $.id; + + my $cache-lock = Lock.new; + my %cache; + + method new(Str:D $id) { + $cache-lock.protect: { + %cache{$id} //= 2 < $id.chars < 64 && $id ~~ /^<[A..Za..z0..9._-]>+$/ + ?? self.bless(:$id) + !! die "Invalid precompilation id: $id" + } + } + + method new-from-string(Str:D $id) { + $cache-lock.protect: { + %cache{$id} //= self.bless(:id(nqp::sha1($id))) + } + } + + method new-without-check(Str:D $id) { + $cache-lock.protect: { + %cache{$id} //= self.bless(:id($id)) + } + } + + method Str() { $!id } + method IO() { $!id.IO } + method substr(|c) { $!id.substr(|c) } +} + +role CompUnit::PrecompilationDependency { + method id(--> CompUnit::PrecompilationId:D) { ... } + method src(--> Str:D) { ... } + method spec(--> CompUnit::DependencySpecification:D) { ... } + method checksum(--> Str:D) { ... } + method Str() { + "$.id $.src $.spec" + } + method serialize(--> Str:D) { ... } + method deserialize(Str, --> CompUnit::PrecompilationDependency:D) { ... } +} + +role CompUnit::PrecompilationUnit { + method id(--> CompUnit::PrecompilationId:D) { ... } + method path(--> IO::Path:D) { ... } + method modified(--> Instant:D) { ... } + method dependencies(--> Array[CompUnit::PrecompilationDependency]) { ... } + method bytecode(--> Buf:D) { ... } + method checksum(--> Str:D) { ... } + method source-checksum(--> Str:D) { ... } + method bytecode-handle(--> IO::Handle:D) { ... } + method close(--> Nil) { ... } + method is-up-to-date(CompUnit::PrecompilationDependency $dependency, Bool :$check-source --> Bool) { + my $RMD = $*RAKUDO_MODULE_DEBUG; + if $check-source { # a repo changed, so maybe it's a change in our source file + my $source-checksum = $.source-checksum; + + my $srcIO = CompUnit::RepositoryRegistry.file-for-spec($dependency.src) // $dependency.src.IO; + unless $srcIO { + return False unless $srcIO.e; + } + my $current-source-checksum := nqp::sha1($srcIO.slurp(:enc)); + $RMD( + "$.path\nspec: $dependency.spec()\nsource: $srcIO\n" + ~ "source-checksum: $source-checksum\ncurrent-source-checksum: $current-source-checksum" + ) if $RMD; + return False if $source-checksum ne $current-source-checksum; + } + + $RMD("dependency checksum $dependency.checksum() unit: $.checksum()") if $RMD; + + $.checksum eq $dependency.checksum + } +} + +class CompUnit::PrecompilationDependency::File does CompUnit::PrecompilationDependency { + has CompUnit::PrecompilationId $.id; + has Str $.src; + has Str $.checksum is rw; + has Str $!serialized-spec; + has CompUnit::DependencySpecification $.spec; + + method source-name() { + "$.src ($.spec.short-name())" + } + + method deserialize(str $str) { + my $parts := nqp::split("\0", $str); + nqp::p6bindattrinvres( + self.new( + :id(CompUnit::PrecompilationId.new-without-check(nqp::atpos($parts, 0))), + :src(nqp::atpos($parts, 1)), + :checksum(nqp::atpos($parts, 2)) + ), + CompUnit::PrecompilationDependency::File, + '$!serialized-spec', + nqp::atpos($parts, 3), + ); + } + + method spec(--> CompUnit::DependencySpecification:D) { + $!spec //= $!serialized-spec + ?? do { +#?if jvm + my @spec = $!serialized-spec.split("\0", 3); + my @spec-pairs; + for @spec>>.match(/(<-[:]>+)':'(.+)/) { + @spec-pairs.push: .[0].Str => (.[1] ~~ / ^ \d+ $ / ?? .[1].Int !! .[1].Str); + } + CompUnit::DependencySpecification.new: |%(|@spec-pairs); +#?endif +#?if moar + use MONKEY-SEE-NO-EVAL; + EVAL $!serialized-spec; +#?endif + } + !! Nil; + } + + method serialize(--> Str:D) { +#?if jvm + my $specs; + for $.spec.^attributes { + $specs ~= .name.substr(2) ~ ":" ~ $.spec."$(.name.substr(2))"() ~ "\0"; + } + "$.id\0$.src\0$.checksum\0$specs" +#?endif +#?if !jvm + "$.id\0$.src\0$.checksum\0{$!serialized-spec ?? $!serialized-spec !! $!spec.perl}" +#?endif + } + + method Str() { + "$.id $.src $.checksum {$!serialized-spec ?? $!serialized-spec !! $!spec.perl}" + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/AbsolutePath.pm rakudo-2018.03/src/core/CompUnit/Repository/AbsolutePath.pm --- rakudo-2018.02.1/src/core/CompUnit/Repository/AbsolutePath.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/AbsolutePath.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -class CompUnit::Repository::AbsolutePath does CompUnit::Repository { - has %!loaded; - - method need(CompUnit::DependencySpecification $spec, - CompUnit::PrecompilationRepository $precomp = self.precomp-repository() - --> CompUnit:D) - { - return self.next-repo.need($spec, $precomp) if self.next-repo; - X::CompUnit::UnsatisfiedDependency.new(:specification($spec)).throw; - } - - method load(IO::Path:D $file --> CompUnit:D) { - if $file.is-absolute { - - # We have a $file when we hit: require "PATH" or use/require Foo:file; - my $precompiled = - $file.Str.ends-with(Rakudo::Internals.PRECOMP-EXT); - - if $file.f { - return %!loaded{$file} = CompUnit.new( - :handle( - $precompiled - ?? CompUnit::Loader.load-precompilation-file($file) - !! CompUnit::Loader.load-source-file($file) - ), - :short-name($file.Str), - :repo(self), - :repo-id($file.Str), - :$precompiled, - ); - } - } - - return self.next-repo.load($file) if self.next-repo; - die("Could not find $file in:\n" ~ $*REPO.repo-chain.map(*.Str).join("\n").indent(4)); - } - - method loaded(--> Iterable:D) { - return %!loaded.values; - } - - method id() { - 'ap' - } - - method path-spec() { - 'ap#' - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/AbsolutePath.pm6 rakudo-2018.03/src/core/CompUnit/Repository/AbsolutePath.pm6 --- rakudo-2018.02.1/src/core/CompUnit/Repository/AbsolutePath.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/AbsolutePath.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,51 @@ +class CompUnit::Repository::AbsolutePath does CompUnit::Repository { + has %!loaded; + + method need(CompUnit::DependencySpecification $spec, + CompUnit::PrecompilationRepository $precomp = self.precomp-repository() + --> CompUnit:D) + { + return self.next-repo.need($spec, $precomp) if self.next-repo; + X::CompUnit::UnsatisfiedDependency.new(:specification($spec)).throw; + } + + method load(IO::Path:D $file --> CompUnit:D) { + if $file.is-absolute { + + # We have a $file when we hit: require "PATH" or use/require Foo:file; + my $precompiled = + $file.Str.ends-with(Rakudo::Internals.PRECOMP-EXT); + + if $file.f { + return %!loaded{$file} = CompUnit.new( + :handle( + $precompiled + ?? CompUnit::Loader.load-precompilation-file($file) + !! CompUnit::Loader.load-source-file($file) + ), + :short-name($file.Str), + :repo(self), + :repo-id($file.Str), + :$precompiled, + ); + } + } + + return self.next-repo.load($file) if self.next-repo; + die("Could not find $file in:\n" ~ $*REPO.repo-chain.map(*.Str).join("\n").indent(4)); + } + + method loaded(--> Iterable:D) { + return %!loaded.values; + } + + method id() { + 'ap' + } + + method path-spec() { + 'ap#' + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/FileSystem.pm rakudo-2018.03/src/core/CompUnit/Repository/FileSystem.pm --- rakudo-2018.02.1/src/core/CompUnit/Repository/FileSystem.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/FileSystem.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,228 +0,0 @@ -class CompUnit::Repository::FileSystem does CompUnit::Repository::Locally does CompUnit::Repository { - has %!loaded; - has $!precomp; - has $!id; - has %!meta; - has $!precomp-stores; - has $!precomp-store; - - my @extensions = ; - my $extensions := nqp::hash('pm6',1,'pm',1); - - # global cache of files seen - my %seen; - - method !matching-file(CompUnit::DependencySpecification $spec) { - if $spec.from eq 'Perl6' { - my $name = $spec.short-name; - return %!loaded{$name} if %!loaded{$name}:exists; - - my $base := $!prefix.add($name.subst(:g, "::", $*SPEC.dir-sep) ~ '.').Str; - return $base if %seen{$base}:exists; - my $found; - - # find source file - # pick a META6.json if it is there - if not %!meta and (my $meta = $!prefix.add('META6.json')) and $meta.f { - try { - %!meta = Rakudo::Internals::JSON.from-json: $meta.slurp; - CATCH { - when JSONException { - fail "Invalid JSON found in META6.json"; - } - } - } - } - if %!meta { - if %!meta{$name} -> $file { - my $path = $file.IO.is-absolute ?? $file.IO !! $!prefix.add($file); - $found = $path if $path.f; - } - } - - unless ?$found { - # deduce path to compilation unit from package name - for @extensions -> $extension { - my $path = ($base ~ $extension).IO; - $found = $path if $path.f; - last if $found; - } - } - - return $base, $found if $found; - } - False - } - - method !comp-unit-id($name) { - CompUnit::PrecompilationId.new-from-string($name); - } - - method id() { - my $parts := nqp::list_s; - my $prefix = self.prefix; - my $dir := { .match(/ ^ <.ident> [ <[ ' - ]> <.ident> ]* $ /) }; # ' hl - my $file := -> str $file { - nqp::eqat($file,'.pm',nqp::sub_i(nqp::chars($file),3)) - || nqp::eqat($file,'.pm6',nqp::sub_i(nqp::chars($file),4)) - }; - nqp::if( - $!id, - $!id, - ($!id = nqp::if( - $prefix.e, - nqp::stmts( - (my $iter := Rakudo::Internals.DIR-RECURSE( - $prefix.absolute,:$dir,:$file).iterator), - nqp::until( - nqp::eqaddr((my $pulled := $iter.pull-one),IterationEnd), - nqp::if( - nqp::filereadable($pulled), - nqp::push_s($parts,nqp::sha1(slurp($pulled, :enc))), - ) - ), - nqp::if( - (my $next := self.next-repo), - nqp::push_s($parts,$next.id), - ), - nqp::sha1(nqp::join('',$parts)) - ), - nqp::sha1('') - )) - ) - } - - method resolve(CompUnit::DependencySpecification $spec --> CompUnit:D) { - my ($base, $file) = self!matching-file($spec); - - return CompUnit.new( - :short-name($spec.short-name), - :repo-id(self!comp-unit-id($spec.short-name).Str), - :repo(self) - ) if $base; - return self.next-repo.resolve($spec) if self.next-repo; - Nil - } - - method !precomp-stores() { - $!precomp-stores //= Array[CompUnit::PrecompilationStore].new( - gather { - my $repo = $*REPO; - while $repo { - my \store = $repo.precomp-store; - take store if store.defined; - $repo = $repo.next-repo; - } - } - ) - } - - method need( - CompUnit::DependencySpecification $spec, - CompUnit::PrecompilationRepository $precomp = self.precomp-repository(), - CompUnit::PrecompilationStore :@precomp-stores = self!precomp-stores(), - - --> CompUnit:D) - { - my ($base, $file) = self!matching-file($spec); - if $base { - my $name = $spec.short-name; - return %!loaded{$name} if %!loaded{$name}:exists; - return %seen{$base} if %seen{$base}:exists; - - my $id = self!comp-unit-id($name); - my $*RESOURCES = Distribution::Resources.new(:repo(self), :dist-id('')); - my $handle = $precomp.try-load( - CompUnit::PrecompilationDependency::File.new( - :$id, - :src($file.Str), - :$spec, - ), - :@precomp-stores, - ); - my $precompiled = defined $handle; - $handle //= CompUnit::Loader.load-source-file($file); # precomp failed - - return %!loaded{$name} = %seen{$base} = CompUnit.new( - :short-name($name), - :$handle, - :repo(self), - :repo-id($id.Str), - :$precompiled, - ); - } - - return self.next-repo.need($spec, $precomp, :@precomp-stores) if self.next-repo; - X::CompUnit::UnsatisfiedDependency.new(:specification($spec)).throw; - } - - method load(IO::Path:D $file --> CompUnit:D) { - unless $file.is-absolute { - - # We have a $file when we hit: require "PATH" or use/require Foo:file; - my $precompiled = - $file.Str.ends-with(Rakudo::Internals.PRECOMP-EXT); - my $path = $!prefix.add($file); - - if $path.f { - return %!loaded{$file.Str} //= %seen{$path.Str} = CompUnit.new( - :handle( - $precompiled - ?? CompUnit::Loader.load-precompilation-file($path) - !! CompUnit::Loader.load-source-file($path) - ), - :short-name($file.Str), - :repo(self), - :repo-id($file.Str), - :$precompiled, - ); - } - } - - return self.next-repo.load($file) if self.next-repo; - nqp::die("Could not find $file in:\n" ~ $*REPO.repo-chain.map(*.Str).join("\n").indent(4)); - } - - method short-id() { 'file' } - - method loaded(--> Iterable:D) { - return %!loaded.values; - } - - method files($file, :$name, :$auth, :$ver) { - my $base := $file.IO; - $base.f - ?? { files => { $file => $base.path }, ver => Version.new('0') } - !! (); - } - - method resource($dist-id, $key) { - # We now save the 'resources/' part of a resource's path in files, i.e: - # "files" : [ "resources/libraries/xxx" => "resources/libraries/xxx.so" ] - # but we also want to root any path request to the CUR's resources directory - - # When $.prefix points at a directory containing a meta file (eg. -I.) - return $.prefix.add( %!meta{$key} ) - if %!meta && %!meta{$key}; - return $.prefix.add( $key ) - if %!meta && %!meta.first({ $_ eq $key.subst(/^resources\//, "") }); - - # When $.prefix is presumably the 'lib' folder (eg. -Ilib) - return $.prefix.parent.add($key); - } - - method precomp-store(--> CompUnit::PrecompilationStore:D) { - $!precomp-store //= CompUnit::PrecompilationStore::File.new( - :prefix(self.prefix.add('.precomp')), - ) - } - - method precomp-repository(--> CompUnit::PrecompilationRepository:D) { - $!precomp := CompUnit::PrecompilationRepository::Default.new( - :store(self.precomp-store), - ) unless $!precomp; - $!precomp - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/FileSystem.pm6 rakudo-2018.03/src/core/CompUnit/Repository/FileSystem.pm6 --- rakudo-2018.02.1/src/core/CompUnit/Repository/FileSystem.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/FileSystem.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,228 @@ +class CompUnit::Repository::FileSystem does CompUnit::Repository::Locally does CompUnit::Repository { + has %!loaded; + has $!precomp; + has $!id; + has %!meta; + has $!precomp-stores; + has $!precomp-store; + + my @extensions = ; + my $extensions := nqp::hash('pm6',1,'pm',1); + + # global cache of files seen + my %seen; + + method !matching-file(CompUnit::DependencySpecification $spec) { + if $spec.from eq 'Perl6' { + my $name = $spec.short-name; + return %!loaded{$name} if %!loaded{$name}:exists; + + my $base := $!prefix.add($name.subst(:g, "::", $*SPEC.dir-sep) ~ '.').Str; + return $base if %seen{$base}:exists; + my $found; + + # find source file + # pick a META6.json if it is there + if not %!meta and (my $meta = $!prefix.add('META6.json')) and $meta.f { + try { + %!meta = Rakudo::Internals::JSON.from-json: $meta.slurp; + CATCH { + when JSONException { + fail "Invalid JSON found in META6.json"; + } + } + } + } + if %!meta { + if %!meta{$name} -> $file { + my $path = $file.IO.is-absolute ?? $file.IO !! $!prefix.add($file); + $found = $path if $path.f; + } + } + + unless ?$found { + # deduce path to compilation unit from package name + for @extensions -> $extension { + my $path = ($base ~ $extension).IO; + $found = $path if $path.f; + last if $found; + } + } + + return $base, $found if $found; + } + False + } + + method !comp-unit-id($name) { + CompUnit::PrecompilationId.new-from-string($name); + } + + method id() { + my $parts := nqp::list_s; + my $prefix = self.prefix; + my $dir := { .match(/ ^ <.ident> [ <[ ' - ]> <.ident> ]* $ /) }; # ' hl + my $file := -> str $file { + nqp::eqat($file,'.pm',nqp::sub_i(nqp::chars($file),3)) + || nqp::eqat($file,'.pm6',nqp::sub_i(nqp::chars($file),4)) + }; + nqp::if( + $!id, + $!id, + ($!id = nqp::if( + $prefix.e, + nqp::stmts( + (my $iter := Rakudo::Internals.DIR-RECURSE( + $prefix.absolute,:$dir,:$file).iterator), + nqp::until( + nqp::eqaddr((my $pulled := $iter.pull-one),IterationEnd), + nqp::if( + nqp::filereadable($pulled), + nqp::push_s($parts,nqp::sha1(slurp($pulled, :enc))), + ) + ), + nqp::if( + (my $next := self.next-repo), + nqp::push_s($parts,$next.id), + ), + nqp::sha1(nqp::join('',$parts)) + ), + nqp::sha1('') + )) + ) + } + + method resolve(CompUnit::DependencySpecification $spec --> CompUnit:D) { + my ($base, $file) = self!matching-file($spec); + + return CompUnit.new( + :short-name($spec.short-name), + :repo-id(self!comp-unit-id($spec.short-name).Str), + :repo(self) + ) if $base; + return self.next-repo.resolve($spec) if self.next-repo; + Nil + } + + method !precomp-stores() { + $!precomp-stores //= Array[CompUnit::PrecompilationStore].new( + gather { + my $repo = $*REPO; + while $repo { + my \store = $repo.precomp-store; + take store if store.defined; + $repo = $repo.next-repo; + } + } + ) + } + + method need( + CompUnit::DependencySpecification $spec, + CompUnit::PrecompilationRepository $precomp = self.precomp-repository(), + CompUnit::PrecompilationStore :@precomp-stores = self!precomp-stores(), + + --> CompUnit:D) + { + my ($base, $file) = self!matching-file($spec); + if $base { + my $name = $spec.short-name; + return %!loaded{$name} if %!loaded{$name}:exists; + return %seen{$base} if %seen{$base}:exists; + + my $id = self!comp-unit-id($name); + my $*RESOURCES = Distribution::Resources.new(:repo(self), :dist-id('')); + my $handle = $precomp.try-load( + CompUnit::PrecompilationDependency::File.new( + :$id, + :src($file.Str), + :$spec, + ), + :@precomp-stores, + ); + my $precompiled = defined $handle; + $handle //= CompUnit::Loader.load-source-file($file); # precomp failed + + return %!loaded{$name} = %seen{$base} = CompUnit.new( + :short-name($name), + :$handle, + :repo(self), + :repo-id($id.Str), + :$precompiled, + ); + } + + return self.next-repo.need($spec, $precomp, :@precomp-stores) if self.next-repo; + X::CompUnit::UnsatisfiedDependency.new(:specification($spec)).throw; + } + + method load(IO::Path:D $file --> CompUnit:D) { + unless $file.is-absolute { + + # We have a $file when we hit: require "PATH" or use/require Foo:file; + my $precompiled = + $file.Str.ends-with(Rakudo::Internals.PRECOMP-EXT); + my $path = $!prefix.add($file); + + if $path.f { + return %!loaded{$file.Str} //= %seen{$path.Str} = CompUnit.new( + :handle( + $precompiled + ?? CompUnit::Loader.load-precompilation-file($path) + !! CompUnit::Loader.load-source-file($path) + ), + :short-name($file.Str), + :repo(self), + :repo-id($file.Str), + :$precompiled, + ); + } + } + + return self.next-repo.load($file) if self.next-repo; + nqp::die("Could not find $file in:\n" ~ $*REPO.repo-chain.map(*.Str).join("\n").indent(4)); + } + + method short-id() { 'file' } + + method loaded(--> Iterable:D) { + return %!loaded.values; + } + + method files($file, :$name, :$auth, :$ver) { + my $base := $file.IO; + $base.f + ?? { files => { $file => $base.path }, ver => Version.new('0') } + !! (); + } + + method resource($dist-id, $key) { + # We now save the 'resources/' part of a resource's path in files, i.e: + # "files" : [ "resources/libraries/xxx" => "resources/libraries/xxx.so" ] + # but we also want to root any path request to the CUR's resources directory + + # When $.prefix points at a directory containing a meta file (eg. -I.) + return $.prefix.add( %!meta{$key} ) + if %!meta && %!meta{$key}; + return $.prefix.add( $key ) + if %!meta && %!meta.first({ $_ eq $key.subst(/^resources\//, "") }); + + # When $.prefix is presumably the 'lib' folder (eg. -Ilib) + return $.prefix.parent.add($key); + } + + method precomp-store(--> CompUnit::PrecompilationStore:D) { + $!precomp-store //= CompUnit::PrecompilationStore::File.new( + :prefix(self.prefix.add('.precomp')), + ) + } + + method precomp-repository(--> CompUnit::PrecompilationRepository:D) { + $!precomp := CompUnit::PrecompilationRepository::Default.new( + :store(self.precomp-store), + ) unless $!precomp; + $!precomp + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/Installable.pm rakudo-2018.03/src/core/CompUnit/Repository/Installable.pm --- rakudo-2018.02.1/src/core/CompUnit/Repository/Installable.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/Installable.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -role CompUnit::Repository::Installable does CompUnit::Repository { - # Installs a distribution into the repository. - method install(Distribution $dist) { ... } - - # Returns True if we can install modules (this will typically do a - # .w check on the module database). - method can-install(--> Bool:D) { ... } - - # Returns the Distribution objects for all installed distributions. - method installed(--> Iterable:D) { } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/Installable.pm6 rakudo-2018.03/src/core/CompUnit/Repository/Installable.pm6 --- rakudo-2018.02.1/src/core/CompUnit/Repository/Installable.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/Installable.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,13 @@ +role CompUnit::Repository::Installable does CompUnit::Repository { + # Installs a distribution into the repository. + method install(Distribution $dist) { ... } + + # Returns True if we can install modules (this will typically do a + # .w check on the module database). + method can-install(--> Bool:D) { ... } + + # Returns the Distribution objects for all installed distributions. + method installed(--> Iterable:D) { } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/Installation.pm rakudo-2018.03/src/core/CompUnit/Repository/Installation.pm --- rakudo-2018.02.1/src/core/CompUnit/Repository/Installation.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/Installation.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,605 +0,0 @@ -class CompUnit::Repository::Installation does CompUnit::Repository::Locally does CompUnit::Repository::Installable { - has $!cver = nqp::hllize(nqp::atkey(nqp::gethllsym('perl6', '$COMPILER_CONFIG'), 'version')); - has %!loaded; - has $!precomp; - has $!id; - has Int $!version; - has %!dist-metas; - has $!precomp-stores; - has $!precomp-store; - - my $verbose := nqp::getenvhash; - - submethod BUILD(:$!prefix, :$!lock, :$!WHICH, :$!next-repo --> Nil) { } - - my class InstalledDistribution is Distribution::Hash { - method content($address) { - my $entry = $.meta.values.first: { $_{$address}:exists }; - my $file = $entry - ?? $.prefix.add('sources').add($entry{$address}) - !! $.prefix.add('resources').add($.meta{$address}); - - $file.open(:r) - } - } - - method writeable-path { - $.prefix.w ?? $.prefix !! IO::Path; - } - - method !writeable-path { - self.can-install ?? $.prefix !! IO::Path; - } - - method can-install() { - $.prefix.w || ?(!$.prefix.e && try { $.prefix.mkdir } && $.prefix.e); - } - - my $windows_wrapper = '@rem = \'--*-Perl-*-- -@echo off -if "%OS%" == "Windows_NT" goto WinNT -#perl# "%~dpn0" %1 %2 %3 %4 %5 %6 %7 %8 %9 -goto endofperl -:WinNT -#perl# "%~dpn0" %* -if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl -if %errorlevel% == 9009 echo You do not have Perl in your PATH. -if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul -goto endofperl -@rem \'; -__END__ -:endofperl -'; - my $perl_wrapper = '#!/usr/bin/env #perl# -sub MAIN(:$name is copy, :$auth, :$ver, *@, *%) { - CompUnit::RepositoryRegistry.run-script("#name#", :dist-name<#dist-name#>, :$name, :$auth, :$ver); -}'; - - method !sources-dir() { - my $sources = $.prefix.add('sources'); - $sources.mkdir unless $sources.e; - $sources - } - - method !resources-dir() { - my $resources = $.prefix.add('resources'); - $resources.mkdir unless $resources.e; - $resources - } - - method !dist-dir() { - my $dist = $.prefix.add('dist'); - $dist.mkdir unless $dist.e; - $dist - } - - method !bin-dir() { - my $bin = $.prefix.add('bin'); - $bin.mkdir unless $bin.e; - $bin - } - - method !add-short-name($name, $dist, $source?, $checksum?) { - my $short-dir = $.prefix.add('short'); - my $id = nqp::sha1($name); - my $lookup = $short-dir.add($id); - $lookup.mkdir; - $lookup.add($dist.id).spurt( - "{$dist.meta // ''}\n" - ~ "{$dist.meta // ''}\n" - ~ "{$dist.meta // ''}\n" - ~ "{$source // ''}\n" - ~ "{$checksum // ''}\n" - ); - } - - method !remove-dist-from-short-name-lookup-files($dist --> Nil) { - my $short-dir = $.prefix.add('short'); - return unless $short-dir.e; - - my $id = $dist.id; - - for $short-dir.dir -> $dir { - $dir.add($id).unlink; - $dir.rmdir unless $dir.dir; - } - } - - method !file-id(Str $name, Str $dist-id) { - my $id = $name ~ $dist-id; - nqp::sha1($id) - } - - method name(--> Str:D) { - CompUnit::RepositoryRegistry.name-for-repository(self) - } - - method !repo-prefix() { - my $repo-prefix = self.name // ''; - $repo-prefix ~= '#' if $repo-prefix; - $repo-prefix - } - - method !read-dist($id) { - my $dist = Rakudo::Internals::JSON.from-json($.prefix.add('dist').add($id).slurp); - $dist = $dist ?? Version.new( ~$dist ) !! Version.new('0'); - $dist - } - - method !repository-version(--> Int:D) { - return $!version if defined $!version; - my $version-file = $.prefix.add('version'); - return $!version = 0 unless $version-file ~~ :f; - $!version = $version-file.slurp.Int - } - - method upgrade-repository() { - my $version = self!repository-version; - my $short-dir = $.prefix.add('short'); - mkdir $short-dir unless $short-dir.e; - my $precomp-dir = $.prefix.add('precomp'); - mkdir $precomp-dir unless $precomp-dir.e; - self!sources-dir; - my $resources-dir = self!resources-dir; - my $dist-dir = self!dist-dir; - self!bin-dir; - if ($version < 1) { - for $short-dir.dir -> $file { - my @ids = $file.lines.unique; - $file.unlink; - $file.mkdir; - for @ids -> $id { - my $dist = self!read-dist($id); - $file.add($id).spurt("{$dist // ''}\n{$dist // ''}\n{$dist // ''}\n"); - } - } - } - if ($version < 2) { - for $dist-dir.dir -> $dist-file { - my %meta = Rakudo::Internals::JSON.from-json($dist-file.slurp); - my $files = %meta //= []; - for eager $files.keys -> $file { - $files{"resources/$file"} = $files{$file}:delete - if $resources-dir.add($files{$file}).e - and not $.prefix.add($file).e; # bin/ is already included in the path - } - $dist-file.spurt: Rakudo::Internals::JSON.to-json(%meta); - } - } - $.prefix.add('version').spurt('2'); - $!version = 2; - } - - proto method install(|) {*} - multi method install($dist, %sources, %scripts?, %resources?, Bool :$force) { - # XXX: Deprecation shim - my %files; - %files{"bin/$_.key()"} = $_.value for %scripts.pairs; - %files{"resources/$_.key()"} = $_.value for %resources.pairs; - my %meta6 = %( - name => $dist.?name, - ver => $dist.?ver // $dist.?version, - auth => $dist.?auth // $dist.?authority, - provides => %sources, - files => %files, - ); - - return samewith(Distribution::Hash.new(%meta6, :prefix($*CWD)), :$force); - } - multi method install(Distribution $distribution, Bool :$force) { - my $dist = CompUnit::Repository::Distribution.new($distribution); - my %files = $dist.meta.grep(*.defined).map: -> $link { - $link ~~ Str ?? ($link => $link) !! ($link.keys[0] => $link.values[0]) - } - - $!lock.protect( { - my @*MODULES; - my $path = self!writeable-path or die "No writeable path found, $.prefix not writeable"; - my $lock = $.prefix.add('repo.lock').open(:create, :w); - $lock.lock; - - my $version = self!repository-version; - self.upgrade-repository unless $version == 2; - - my $dist-id = $dist.id; - my $dist-dir = self!dist-dir; - if not $force and $dist-dir.add($dist-id) ~~ :e { - $lock.unlock; - fail "$dist already installed"; - } - - my $sources-dir = self!sources-dir; - my $resources-dir = self!resources-dir; - my $bin-dir = self!bin-dir; - my $is-win = Rakudo::Internals.IS-WIN; - - self!add-short-name($dist.meta, $dist); # so scripts can find their dist - - my %links; # map name-path to new content address - my %provides; # meta data gets added, but the format needs to change to - # only extend the structure, not change it - - # the following 3 `for` loops should be a single loop, but has been - # left this way due to impeding precomp changes - - # lib/ source files - for $dist.meta.kv -> $name, $file is copy { - # $name is "Inline::Perl5" while $file is "lib/Inline/Perl5.pm6" - my $id = self!file-id(~$name, $dist-id); - my $destination = $sources-dir.add($id); - my $handle = $dist.content($file); - my $content = $handle.open(:bin).slurp(:close); - - self!add-short-name($name, $dist, $id, - nqp::sha1(nqp::join("\n", nqp::split("\r\n", - $content.decode('iso-8859-1'))))); - %provides{ $name } = ~$file => { - :file($id), - :time(try $file.IO.modified.Num), - :$!cver - }; - note("Installing {$name} for {$dist.meta}") if $verbose and $name ne $dist.meta; - $destination.spurt($content); - } - - # bin/ scripts - for %files.kv -> $name-path, $file is copy { - next unless $name-path.starts-with('bin/'); - my $id = self!file-id(~$file, $dist-id); - my $destination = $resources-dir.add($id); # wrappers are put in bin/; originals in resources/ - my $withoutext = $name-path.subst(/\.[exe|bat]$/, ''); - for '', '-j', '-m' -> $be { - $.prefix.add("$withoutext$be").IO.spurt: - $perl_wrapper.subst('#name#', $name-path.IO.basename, :g).subst('#perl#', "perl6$be").subst('#dist-name#', $dist.meta); - if $is-win { - $.prefix.add("$withoutext$be.bat").IO.spurt: - $windows_wrapper.subst('#perl#', "perl6$be", :g); - } - else { - $.prefix.add("$withoutext$be").IO.chmod(0o755); - } - } - self!add-short-name($name-path, $dist, $id); - %links{$name-path} = $id; - my $handle = $dist.content($file); - my $content = $handle.open.slurp-rest(:bin,:close); - $destination.spurt($content); - $handle.close; - } - - # resources/ - for %files.kv -> $name-path, $file is copy { - next unless $name-path.starts-with('resources/'); - # $name-path is 'resources/libraries/p5helper' while $file is 'resources/libraries/libp5helper.so' - my $id = self!file-id(~$name-path, $dist-id) ~ '.' ~ $file.IO.extension; - my $destination = $resources-dir.add($id); - %links{$name-path} = $id; - my $handle = $dist.content($file); - my $content = $handle.open.slurp-rest(:bin,:close); - $destination.spurt($content); - $handle.close; - } - - my %meta = %($dist.meta); - %meta = %links; # add our new name-path => conent-id mapping - %meta = %provides; # new meta data added to provides - %!dist-metas{$dist-id} = %meta; - $dist-dir.add($dist-id).spurt: Rakudo::Internals::JSON.to-json(%meta); - - # reset cached id so it's generated again on next access. - # identity changes with every installation of a dist. - $!id = Any; - - { - my $head = $*REPO; - PROCESS::<$REPO> := self; # Precomp files should only depend on downstream repos - my $precomp = $*REPO.precomp-repository; - my $repo-prefix = self!repo-prefix; - my $*RESOURCES = Distribution::Resources.new(:repo(self), :$dist-id); - my %done; - - my $compiler-id = CompUnit::PrecompilationId.new-without-check($*PERL.compiler.id); - for %provides.kv -> $source-name, $source-meta { - my $id = CompUnit::PrecompilationId.new-without-check($source-meta.values[0]); - $precomp.store.delete($compiler-id, $id); - } - - for %provides.kv -> $source-name, $source-meta { - my $id = $source-meta.values[0]; - my $source = $sources-dir.add($id); - my $source-file = $repo-prefix ?? $repo-prefix ~ $source.relative($.prefix) !! $source; - - if %done{$id} { - note "(Already did $id)" if $verbose; - next; - } - note("Precompiling $id ($source-name)") if $verbose; - $precomp.precompile( - $source, - CompUnit::PrecompilationId.new-without-check($id), - :source-name("$source-file ($source-name)"), - ); - %done{$id} = 1; - } - PROCESS::<$REPO> := $head; - } - - $lock.unlock; - } ) } - - method uninstall(Distribution $distribution) { - my $repo-version = self!repository-version; - self.upgrade-repository unless $repo-version == 2; - - # xxx: currently needs to be passed in a distribution object that - # has meta pointing at content-ids, so you cannot yet just - # pass in the original meta data and have it discovered and deleted - # (i.e. update resolve to return such a ::Installation::Distribution) - my $dist = CompUnit::Repository::Distribution.new($distribution); - my %provides = $dist.meta; - my %files = $dist.meta; - my $sources-dir = self.prefix.add('sources'); - my $resources-dir = self.prefix.add('resources'); - my $bin-dir = self.prefix.add('bin'); - my $dist-dir = self.prefix.add('dist'); - - self!remove-dist-from-short-name-lookup-files($dist); - my sub unlink-if-exists($path) { unlink($path) if $path.IO.e } - - # delete special directory files - for %files.kv -> $name-path, $file { - given $name-path { - when /^bin\/(.*)/ { - # wrappers are located in $bin-dir (only delete if no other versions use wrapper) - unless self.files($name-path, :name($dist.meta)).elems { - unlink-if-exists( $bin-dir.add("$0$_") ) for '', '-m', '-j'; - } - - # original bin scripts are in $resources-dir - unlink-if-exists( $resources-dir.add($file) ) - } - when /^resources\// { - unlink-if-exists( $resources-dir.add($file) ) - } - } - } - - # delete sources - unlink-if-exists( $sources-dir.add($_) ) for %provides.values.flatmap(*.values.map(*.)); - - # delete the meta file - unlink( $dist-dir.add($dist.id) ) - } - - method script($file, :$name!, :$auth, :$ver) { - my $prefix = self.prefix; - my $lookup = $prefix.add('short').add(nqp::sha1($file)); - return unless $lookup.e; - - # Scripts using this interface could only have been installed long after the introduction of - # repo version 1, so we don't have to care about very old repos in this method. - my @dists = $lookup.dir.map({ - my ($ver, $auth, $api, $resource-id) = $_.slurp.split("\n"); - $resource-id ||= self!read-dist($_.basename){$file}; - (id => $_.basename, ver => Version.new( $ver || 0 ), :$auth, :$api, :$resource-id).hash - }).grep({ - $_. ~~ $auth - and $_. ~~ $ver - }); - for @dists.sort(*.).reverse { - return self!resources-dir.add($_); - } - } - - method files($file, :$name!, :$auth, :$ver) { - my @candi; - my $prefix = self.prefix; - my $lookup = $prefix.add('short').add(nqp::sha1($name)); - if $lookup.e { - my $repo-version = self!repository-version; - my @dists = $repo-version < 1 - ?? $lookup.lines.unique.map({ - self!read-dist($_) - }) - !! $lookup.dir.map({ - my ($ver, $auth, $api) = $_.slurp.split("\n"); - (id => $_.basename, ver => Version.new( $ver || 0 ), auth => $auth, api => $api).hash - }); - for @dists.grep({$_ ~~ $auth and $_ ~~ $ver}) -> $dist is copy { - $dist = self!read-dist($dist) if $repo-version >= 1; - with $dist{$file} { - my $candi = %$dist; - $candi{$file} = self!resources-dir.add($candi{$file}); - @candi.push: $candi; - } - } - } - @candi - } - - method !matching-dist(CompUnit::DependencySpecification $spec) { - if $spec.from eq 'Perl6' { - my $repo-version = self!repository-version; - my $lookup = $.prefix.add('short').add(nqp::sha1($spec.short-name)); - if $lookup.e { - my @dists = ( - $repo-version < 1 - ?? $lookup.lines.unique.map({ - $_ => self!read-dist($_) - }) - !! $lookup.dir.map({ - my ($ver, $auth, $api, $source, $checksum) = $_.slurp.split("\n"); - $_.basename => { - ver => Version.new( $ver || 0 ), - auth => $auth, - api => $api, - source => $source || Any, - checksum => $checksum || Str, - } - }) - ).grep({ - $_.value ~~ $spec.auth-matcher - and $_.value ~~ (($spec.version-matcher ~~ Bool) - ?? $spec.version-matcher # fast path for matching Version.new(*) - !! Version.new($spec.version-matcher)) - }); - for @dists.sort(*.value).reverse.map(*.kv) -> ($dist-id, $dist) { - return ($dist-id, $dist); - } - } - } - Nil - } - - method !lazy-distribution($dist-id) { - class :: does Distribution::Locally { - has $.dist-id; - has $.read-dist; - has $!installed-dist; - method !dist { - $!installed-dist //= InstalledDistribution.new($.read-dist()(), :$.prefix) - } - method meta(--> Hash:D) { self!dist.meta } - method content($content-id --> IO::Handle:D) { self!dist.content($content-id) } - method Str() { self!dist.Str } - }.new( - :$dist-id, - :read-dist(-> { self!read-dist($dist-id) }) - :$.prefix, - ) - } - - method resolve( - CompUnit::DependencySpecification $spec, - --> CompUnit:D) - { - my ($dist-id, $dist) = self!matching-dist($spec); - if $dist-id { - # xxx: replace :distribution with meta6 - return CompUnit.new( - :handle(CompUnit::Handle), - :short-name($spec.short-name), - :version($dist), - :auth($dist // Str), - :repo(self), - :repo-id($dist // self!read-dist($dist-id){$spec.short-name}.values[0]), - :distribution(self!lazy-distribution($dist-id)), - ); - } - return self.next-repo.resolve($spec) if self.next-repo; - Nil - } - - method !precomp-stores() { - $!precomp-stores //= Array[CompUnit::PrecompilationStore].new( - self.repo-chain.map(*.precomp-store).grep(*.defined) - ) - } - - method need( - CompUnit::DependencySpecification $spec, - CompUnit::PrecompilationRepository $precomp = self.precomp-repository(), - CompUnit::PrecompilationStore :@precomp-stores = self!precomp-stores(), - --> CompUnit:D) - { - my ($dist-id, $dist) = self!matching-dist($spec); - if $dist-id { - return %!loaded{~$spec} if %!loaded{~$spec}:exists; - my $source-file-name = $dist - // do { - my $provides = self!read-dist($dist-id); - X::CompUnit::UnsatisfiedDependency.new(:specification($spec)).throw - unless $provides{$spec.short-name}:exists; - $provides{$spec.short-name}.values[0] - }; - my $loader = $.prefix.add('sources').add($source-file-name); - my $*RESOURCES = Distribution::Resources.new(:repo(self), :$dist-id); - my $id = $loader.basename; - my $repo-prefix = self!repo-prefix; - my $handle = $precomp.try-load( - CompUnit::PrecompilationDependency::File.new( - :id(CompUnit::PrecompilationId.new-without-check($id)), - :src($repo-prefix ?? $repo-prefix ~ $loader.relative($.prefix) !! $loader.absolute), - :checksum($dist:exists ?? $dist !! Str), - :$spec, - ), - :source($loader), - :@precomp-stores, - ); - my $precompiled = defined $handle; - $handle //= CompUnit::Loader.load-source-file($loader); - - # xxx: replace :distribution with meta6 - my $compunit = CompUnit.new( - :$handle, - :short-name($spec.short-name), - :version($dist), - :auth($dist // Str), - :repo(self), - :repo-id($id), - :$precompiled, - :distribution(self!lazy-distribution($dist-id)), - ); - return %!loaded{~$spec} = $compunit; - } - return self.next-repo.need($spec, $precomp, :@precomp-stores) if self.next-repo; - X::CompUnit::UnsatisfiedDependency.new(:specification($spec)).throw; - } - - method resource($dist-id, $key) { - my $dist = %!dist-metas{$dist-id} //= Rakudo::Internals::JSON.from-json(self!dist-dir.add($dist-id).slurp); - # need to strip the leading resources/ on old repositories - self!resources-dir.add($dist{$key.substr(self!repository-version < 2 ?? 10 !! 0)}) - } - - method id() { - return $!id if $!id; - my $name = self.path-spec; - $name ~= ',' ~ self.next-repo.id if self.next-repo; - my $dist-dir = $.prefix.add('dist'); - $!id = nqp::sha1(nqp::sha1($name) ~ ($dist-dir.e ?? $dist-dir.dir !! '')) - } - - method short-id() { 'inst' } - - method loaded(--> Iterable:D) { - return %!loaded.values; - } - - method distribution($id) { - InstalledDistribution.new(self!read-dist($id), :prefix(self.prefix)) - } - - method installed(--> Iterable:D) { - my $dist-dir = self.prefix.add('dist'); - $dist-dir.e - ?? $dist-dir.dir.map({ self.distribution($_.basename) }) - !! Nil - } - - method precomp-store(--> CompUnit::PrecompilationStore:D) { - $!precomp-store //= CompUnit::PrecompilationStore::File.new( - :prefix(self.prefix.add('precomp')), - ) - } - - method precomp-repository(--> CompUnit::PrecompilationRepository:D) { - $!precomp := CompUnit::PrecompilationRepository::Default.new( - :store(self.precomp-store), - ) unless $!precomp; - $!precomp - } - - sub provides-warning($is-win, $name --> Nil) { - my ($red,$clear) = Rakudo::Internals.error-rcgye; - - note "$red==={$clear}WARNING!$red===$clear -The distribution $name does not seem to have a \"provides\" section in its META.info file, -and so the packages will not be installed in the correct location. -Please ask the author to add a \"provides\" section, mapping every exposed namespace to a -file location in the distribution. -See http://design.perl6.org/S22.html#provides for more information.\n"; - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/Installation.pm6 rakudo-2018.03/src/core/CompUnit/Repository/Installation.pm6 --- rakudo-2018.02.1/src/core/CompUnit/Repository/Installation.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/Installation.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,605 @@ +class CompUnit::Repository::Installation does CompUnit::Repository::Locally does CompUnit::Repository::Installable { + has $!cver = nqp::hllize(nqp::atkey(nqp::gethllsym('perl6', '$COMPILER_CONFIG'), 'version')); + has %!loaded; + has $!precomp; + has $!id; + has Int $!version; + has %!dist-metas; + has $!precomp-stores; + has $!precomp-store; + + my $verbose := nqp::getenvhash; + + submethod BUILD(:$!prefix, :$!lock, :$!WHICH, :$!next-repo --> Nil) { } + + my class InstalledDistribution is Distribution::Hash { + method content($address) { + my $entry = $.meta.values.first: { $_{$address}:exists }; + my $file = $entry + ?? $.prefix.add('sources').add($entry{$address}) + !! $.prefix.add('resources').add($.meta{$address}); + + $file.open(:r) + } + } + + method writeable-path { + $.prefix.w ?? $.prefix !! IO::Path; + } + + method !writeable-path { + self.can-install ?? $.prefix !! IO::Path; + } + + method can-install() { + $.prefix.w || ?(!$.prefix.e && try { $.prefix.mkdir } && $.prefix.e); + } + + my $windows_wrapper = '@rem = \'--*-Perl-*-- +@echo off +if "%OS%" == "Windows_NT" goto WinNT +#perl# "%~dpn0" %1 %2 %3 %4 %5 %6 %7 %8 %9 +goto endofperl +:WinNT +#perl# "%~dpn0" %* +if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl +if %errorlevel% == 9009 echo You do not have Perl in your PATH. +if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul +goto endofperl +@rem \'; +__END__ +:endofperl +'; + my $perl_wrapper = '#!/usr/bin/env #perl# +sub MAIN(:$name is copy, :$auth, :$ver, *@, *%) { + CompUnit::RepositoryRegistry.run-script("#name#", :dist-name<#dist-name#>, :$name, :$auth, :$ver); +}'; + + method !sources-dir() { + my $sources = $.prefix.add('sources'); + $sources.mkdir unless $sources.e; + $sources + } + + method !resources-dir() { + my $resources = $.prefix.add('resources'); + $resources.mkdir unless $resources.e; + $resources + } + + method !dist-dir() { + my $dist = $.prefix.add('dist'); + $dist.mkdir unless $dist.e; + $dist + } + + method !bin-dir() { + my $bin = $.prefix.add('bin'); + $bin.mkdir unless $bin.e; + $bin + } + + method !add-short-name($name, $dist, $source?, $checksum?) { + my $short-dir = $.prefix.add('short'); + my $id = nqp::sha1($name); + my $lookup = $short-dir.add($id); + $lookup.mkdir; + $lookup.add($dist.id).spurt( + "{$dist.meta // ''}\n" + ~ "{$dist.meta // ''}\n" + ~ "{$dist.meta // ''}\n" + ~ "{$source // ''}\n" + ~ "{$checksum // ''}\n" + ); + } + + method !remove-dist-from-short-name-lookup-files($dist --> Nil) { + my $short-dir = $.prefix.add('short'); + return unless $short-dir.e; + + my $id = $dist.id; + + for $short-dir.dir -> $dir { + $dir.add($id).unlink; + $dir.rmdir unless $dir.dir; + } + } + + method !file-id(Str $name, Str $dist-id) { + my $id = $name ~ $dist-id; + nqp::sha1($id) + } + + method name(--> Str:D) { + CompUnit::RepositoryRegistry.name-for-repository(self) + } + + method !repo-prefix() { + my $repo-prefix = self.name // ''; + $repo-prefix ~= '#' if $repo-prefix; + $repo-prefix + } + + method !read-dist($id) { + my $dist = Rakudo::Internals::JSON.from-json($.prefix.add('dist').add($id).slurp); + $dist = $dist ?? Version.new( ~$dist ) !! Version.new('0'); + $dist + } + + method !repository-version(--> Int:D) { + return $!version if defined $!version; + my $version-file = $.prefix.add('version'); + return $!version = 0 unless $version-file ~~ :f; + $!version = $version-file.slurp.Int + } + + method upgrade-repository() { + my $version = self!repository-version; + my $short-dir = $.prefix.add('short'); + mkdir $short-dir unless $short-dir.e; + my $precomp-dir = $.prefix.add('precomp'); + mkdir $precomp-dir unless $precomp-dir.e; + self!sources-dir; + my $resources-dir = self!resources-dir; + my $dist-dir = self!dist-dir; + self!bin-dir; + if ($version < 1) { + for $short-dir.dir -> $file { + my @ids = $file.lines.unique; + $file.unlink; + $file.mkdir; + for @ids -> $id { + my $dist = self!read-dist($id); + $file.add($id).spurt("{$dist // ''}\n{$dist // ''}\n{$dist // ''}\n"); + } + } + } + if ($version < 2) { + for $dist-dir.dir -> $dist-file { + my %meta = Rakudo::Internals::JSON.from-json($dist-file.slurp); + my $files = %meta //= []; + for eager $files.keys -> $file { + $files{"resources/$file"} = $files{$file}:delete + if $resources-dir.add($files{$file}).e + and not $.prefix.add($file).e; # bin/ is already included in the path + } + $dist-file.spurt: Rakudo::Internals::JSON.to-json(%meta); + } + } + $.prefix.add('version').spurt('2'); + $!version = 2; + } + + proto method install(|) {*} + multi method install($dist, %sources, %scripts?, %resources?, Bool :$force) { + # XXX: Deprecation shim + my %files; + %files{"bin/$_.key()"} = $_.value for %scripts.pairs; + %files{"resources/$_.key()"} = $_.value for %resources.pairs; + my %meta6 = %( + name => $dist.?name, + ver => $dist.?ver // $dist.?version, + auth => $dist.?auth // $dist.?authority, + provides => %sources, + files => %files, + ); + + return samewith(Distribution::Hash.new(%meta6, :prefix($*CWD)), :$force); + } + multi method install(Distribution $distribution, Bool :$force) { + my $dist = CompUnit::Repository::Distribution.new($distribution); + my %files = $dist.meta.grep(*.defined).map: -> $link { + $link ~~ Str ?? ($link => $link) !! ($link.keys[0] => $link.values[0]) + } + + $!lock.protect( { + my @*MODULES; + my $path = self!writeable-path or die "No writeable path found, $.prefix not writeable"; + my $lock = $.prefix.add('repo.lock').open(:create, :w); + $lock.lock; + + my $version = self!repository-version; + self.upgrade-repository unless $version == 2; + + my $dist-id = $dist.id; + my $dist-dir = self!dist-dir; + if not $force and $dist-dir.add($dist-id) ~~ :e { + $lock.unlock; + fail "$dist already installed"; + } + + my $sources-dir = self!sources-dir; + my $resources-dir = self!resources-dir; + my $bin-dir = self!bin-dir; + my $is-win = Rakudo::Internals.IS-WIN; + + self!add-short-name($dist.meta, $dist); # so scripts can find their dist + + my %links; # map name-path to new content address + my %provides; # meta data gets added, but the format needs to change to + # only extend the structure, not change it + + # the following 3 `for` loops should be a single loop, but has been + # left this way due to impeding precomp changes + + # lib/ source files + for $dist.meta.kv -> $name, $file is copy { + # $name is "Inline::Perl5" while $file is "lib/Inline/Perl5.pm6" + my $id = self!file-id(~$name, $dist-id); + my $destination = $sources-dir.add($id); + my $handle = $dist.content($file); + my $content = $handle.open(:bin).slurp(:close); + + self!add-short-name($name, $dist, $id, + nqp::sha1(nqp::join("\n", nqp::split("\r\n", + $content.decode('iso-8859-1'))))); + %provides{ $name } = ~$file => { + :file($id), + :time(try $file.IO.modified.Num), + :$!cver + }; + note("Installing {$name} for {$dist.meta}") if $verbose and $name ne $dist.meta; + $destination.spurt($content); + } + + # bin/ scripts + for %files.kv -> $name-path, $file is copy { + next unless $name-path.starts-with('bin/'); + my $id = self!file-id(~$file, $dist-id); + my $destination = $resources-dir.add($id); # wrappers are put in bin/; originals in resources/ + my $withoutext = $name-path.subst(/\.[exe|bat]$/, ''); + for '', '-j', '-m' -> $be { + $.prefix.add("$withoutext$be").IO.spurt: + $perl_wrapper.subst('#name#', $name-path.IO.basename, :g).subst('#perl#', "perl6$be").subst('#dist-name#', $dist.meta); + if $is-win { + $.prefix.add("$withoutext$be.bat").IO.spurt: + $windows_wrapper.subst('#perl#', "perl6$be", :g); + } + else { + $.prefix.add("$withoutext$be").IO.chmod(0o755); + } + } + self!add-short-name($name-path, $dist, $id); + %links{$name-path} = $id; + my $handle = $dist.content($file); + my $content = $handle.open.slurp-rest(:bin,:close); + $destination.spurt($content); + $handle.close; + } + + # resources/ + for %files.kv -> $name-path, $file is copy { + next unless $name-path.starts-with('resources/'); + # $name-path is 'resources/libraries/p5helper' while $file is 'resources/libraries/libp5helper.so' + my $id = self!file-id(~$name-path, $dist-id) ~ '.' ~ $file.IO.extension; + my $destination = $resources-dir.add($id); + %links{$name-path} = $id; + my $handle = $dist.content($file); + my $content = $handle.open.slurp-rest(:bin,:close); + $destination.spurt($content); + $handle.close; + } + + my %meta = %($dist.meta); + %meta = %links; # add our new name-path => conent-id mapping + %meta = %provides; # new meta data added to provides + %!dist-metas{$dist-id} = %meta; + $dist-dir.add($dist-id).spurt: Rakudo::Internals::JSON.to-json(%meta); + + # reset cached id so it's generated again on next access. + # identity changes with every installation of a dist. + $!id = Any; + + { + my $head = $*REPO; + PROCESS::<$REPO> := self; # Precomp files should only depend on downstream repos + my $precomp = $*REPO.precomp-repository; + my $repo-prefix = self!repo-prefix; + my $*RESOURCES = Distribution::Resources.new(:repo(self), :$dist-id); + my %done; + + my $compiler-id = CompUnit::PrecompilationId.new-without-check($*PERL.compiler.id); + for %provides.kv -> $source-name, $source-meta { + my $id = CompUnit::PrecompilationId.new-without-check($source-meta.values[0]); + $precomp.store.delete($compiler-id, $id); + } + + for %provides.kv -> $source-name, $source-meta { + my $id = $source-meta.values[0]; + my $source = $sources-dir.add($id); + my $source-file = $repo-prefix ?? $repo-prefix ~ $source.relative($.prefix) !! $source; + + if %done{$id} { + note "(Already did $id)" if $verbose; + next; + } + note("Precompiling $id ($source-name)") if $verbose; + $precomp.precompile( + $source, + CompUnit::PrecompilationId.new-without-check($id), + :source-name("$source-file ($source-name)"), + ); + %done{$id} = 1; + } + PROCESS::<$REPO> := $head; + } + + $lock.unlock; + } ) } + + method uninstall(Distribution $distribution) { + my $repo-version = self!repository-version; + self.upgrade-repository unless $repo-version == 2; + + # xxx: currently needs to be passed in a distribution object that + # has meta pointing at content-ids, so you cannot yet just + # pass in the original meta data and have it discovered and deleted + # (i.e. update resolve to return such a ::Installation::Distribution) + my $dist = CompUnit::Repository::Distribution.new($distribution); + my %provides = $dist.meta; + my %files = $dist.meta; + my $sources-dir = self.prefix.add('sources'); + my $resources-dir = self.prefix.add('resources'); + my $bin-dir = self.prefix.add('bin'); + my $dist-dir = self.prefix.add('dist'); + + self!remove-dist-from-short-name-lookup-files($dist); + my sub unlink-if-exists($path) { unlink($path) if $path.IO.e } + + # delete special directory files + for %files.kv -> $name-path, $file { + given $name-path { + when /^bin\/(.*)/ { + # wrappers are located in $bin-dir (only delete if no other versions use wrapper) + unless self.files($name-path, :name($dist.meta)).elems { + unlink-if-exists( $bin-dir.add("$0$_") ) for '', '-m', '-j'; + } + + # original bin scripts are in $resources-dir + unlink-if-exists( $resources-dir.add($file) ) + } + when /^resources\// { + unlink-if-exists( $resources-dir.add($file) ) + } + } + } + + # delete sources + unlink-if-exists( $sources-dir.add($_) ) for %provides.values.flatmap(*.values.map(*.)); + + # delete the meta file + unlink( $dist-dir.add($dist.id) ) + } + + method script($file, :$name!, :$auth, :$ver) { + my $prefix = self.prefix; + my $lookup = $prefix.add('short').add(nqp::sha1($file)); + return unless $lookup.e; + + # Scripts using this interface could only have been installed long after the introduction of + # repo version 1, so we don't have to care about very old repos in this method. + my @dists = $lookup.dir.map({ + my ($ver, $auth, $api, $resource-id) = $_.slurp.split("\n"); + $resource-id ||= self!read-dist($_.basename){$file}; + (id => $_.basename, ver => Version.new( $ver || 0 ), :$auth, :$api, :$resource-id).hash + }).grep({ + $_. ~~ $auth + and $_. ~~ $ver + }); + for @dists.sort(*.).reverse { + return self!resources-dir.add($_); + } + } + + method files($file, :$name!, :$auth, :$ver) { + my @candi; + my $prefix = self.prefix; + my $lookup = $prefix.add('short').add(nqp::sha1($name)); + if $lookup.e { + my $repo-version = self!repository-version; + my @dists = $repo-version < 1 + ?? $lookup.lines.unique.map({ + self!read-dist($_) + }) + !! $lookup.dir.map({ + my ($ver, $auth, $api) = $_.slurp.split("\n"); + (id => $_.basename, ver => Version.new( $ver || 0 ), auth => $auth, api => $api).hash + }); + for @dists.grep({$_ ~~ $auth and $_ ~~ $ver}) -> $dist is copy { + $dist = self!read-dist($dist) if $repo-version >= 1; + with $dist{$file} { + my $candi = %$dist; + $candi{$file} = self!resources-dir.add($candi{$file}); + @candi.push: $candi; + } + } + } + @candi + } + + method !matching-dist(CompUnit::DependencySpecification $spec) { + if $spec.from eq 'Perl6' { + my $repo-version = self!repository-version; + my $lookup = $.prefix.add('short').add(nqp::sha1($spec.short-name)); + if $lookup.e { + my @dists = ( + $repo-version < 1 + ?? $lookup.lines.unique.map({ + $_ => self!read-dist($_) + }) + !! $lookup.dir.map({ + my ($ver, $auth, $api, $source, $checksum) = $_.slurp.split("\n"); + $_.basename => { + ver => Version.new( $ver || 0 ), + auth => $auth, + api => $api, + source => $source || Any, + checksum => $checksum || Str, + } + }) + ).grep({ + $_.value ~~ $spec.auth-matcher + and $_.value ~~ (($spec.version-matcher ~~ Bool) + ?? $spec.version-matcher # fast path for matching Version.new(*) + !! Version.new($spec.version-matcher)) + }); + for @dists.sort(*.value).reverse.map(*.kv) -> ($dist-id, $dist) { + return ($dist-id, $dist); + } + } + } + Nil + } + + method !lazy-distribution($dist-id) { + class :: does Distribution::Locally { + has $.dist-id; + has $.read-dist; + has $!installed-dist; + method !dist { + $!installed-dist //= InstalledDistribution.new($.read-dist()(), :$.prefix) + } + method meta(--> Hash:D) { self!dist.meta } + method content($content-id --> IO::Handle:D) { self!dist.content($content-id) } + method Str() { self!dist.Str } + }.new( + :$dist-id, + :read-dist(-> { self!read-dist($dist-id) }) + :$.prefix, + ) + } + + method resolve( + CompUnit::DependencySpecification $spec, + --> CompUnit:D) + { + my ($dist-id, $dist) = self!matching-dist($spec); + if $dist-id { + # xxx: replace :distribution with meta6 + return CompUnit.new( + :handle(CompUnit::Handle), + :short-name($spec.short-name), + :version($dist), + :auth($dist // Str), + :repo(self), + :repo-id($dist // self!read-dist($dist-id){$spec.short-name}.values[0]), + :distribution(self!lazy-distribution($dist-id)), + ); + } + return self.next-repo.resolve($spec) if self.next-repo; + Nil + } + + method !precomp-stores() { + $!precomp-stores //= Array[CompUnit::PrecompilationStore].new( + self.repo-chain.map(*.precomp-store).grep(*.defined) + ) + } + + method need( + CompUnit::DependencySpecification $spec, + CompUnit::PrecompilationRepository $precomp = self.precomp-repository(), + CompUnit::PrecompilationStore :@precomp-stores = self!precomp-stores(), + --> CompUnit:D) + { + my ($dist-id, $dist) = self!matching-dist($spec); + if $dist-id { + return %!loaded{~$spec} if %!loaded{~$spec}:exists; + my $source-file-name = $dist + // do { + my $provides = self!read-dist($dist-id); + X::CompUnit::UnsatisfiedDependency.new(:specification($spec)).throw + unless $provides{$spec.short-name}:exists; + $provides{$spec.short-name}.values[0] + }; + my $loader = $.prefix.add('sources').add($source-file-name); + my $*RESOURCES = Distribution::Resources.new(:repo(self), :$dist-id); + my $id = $loader.basename; + my $repo-prefix = self!repo-prefix; + my $handle = $precomp.try-load( + CompUnit::PrecompilationDependency::File.new( + :id(CompUnit::PrecompilationId.new-without-check($id)), + :src($repo-prefix ?? $repo-prefix ~ $loader.relative($.prefix) !! $loader.absolute), + :checksum($dist:exists ?? $dist !! Str), + :$spec, + ), + :source($loader), + :@precomp-stores, + ); + my $precompiled = defined $handle; + $handle //= CompUnit::Loader.load-source-file($loader); + + # xxx: replace :distribution with meta6 + my $compunit = CompUnit.new( + :$handle, + :short-name($spec.short-name), + :version($dist), + :auth($dist // Str), + :repo(self), + :repo-id($id), + :$precompiled, + :distribution(self!lazy-distribution($dist-id)), + ); + return %!loaded{~$spec} = $compunit; + } + return self.next-repo.need($spec, $precomp, :@precomp-stores) if self.next-repo; + X::CompUnit::UnsatisfiedDependency.new(:specification($spec)).throw; + } + + method resource($dist-id, $key) { + my $dist = %!dist-metas{$dist-id} //= Rakudo::Internals::JSON.from-json(self!dist-dir.add($dist-id).slurp); + # need to strip the leading resources/ on old repositories + self!resources-dir.add($dist{$key.substr(self!repository-version < 2 ?? 10 !! 0)}) + } + + method id() { + return $!id if $!id; + my $name = self.path-spec; + $name ~= ',' ~ self.next-repo.id if self.next-repo; + my $dist-dir = $.prefix.add('dist'); + $!id = nqp::sha1(nqp::sha1($name) ~ ($dist-dir.e ?? $dist-dir.dir !! '')) + } + + method short-id() { 'inst' } + + method loaded(--> Iterable:D) { + return %!loaded.values; + } + + method distribution($id) { + InstalledDistribution.new(self!read-dist($id), :prefix(self.prefix)) + } + + method installed(--> Iterable:D) { + my $dist-dir = self.prefix.add('dist'); + $dist-dir.e + ?? $dist-dir.dir.map({ self.distribution($_.basename) }) + !! Nil + } + + method precomp-store(--> CompUnit::PrecompilationStore:D) { + $!precomp-store //= CompUnit::PrecompilationStore::File.new( + :prefix(self.prefix.add('precomp')), + ) + } + + method precomp-repository(--> CompUnit::PrecompilationRepository:D) { + $!precomp := CompUnit::PrecompilationRepository::Default.new( + :store(self.precomp-store), + ) unless $!precomp; + $!precomp + } + + sub provides-warning($is-win, $name --> Nil) { + my ($red,$clear) = Rakudo::Internals.error-rcgye; + + note "$red==={$clear}WARNING!$red===$clear +The distribution $name does not seem to have a \"provides\" section in its META.info file, +and so the packages will not be installed in the correct location. +Please ask the author to add a \"provides\" section, mapping every exposed namespace to a +file location in the distribution. +See http://design.perl6.org/S22.html#provides for more information.\n"; + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/Locally.pm rakudo-2018.03/src/core/CompUnit/Repository/Locally.pm --- rakudo-2018.02.1/src/core/CompUnit/Repository/Locally.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/Locally.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,46 +0,0 @@ -role CompUnit::Repository::Locally { - has Lock $!lock; - has IO::Path $.prefix is required; - has Str $.WHICH; - - method new(CompUnit::Repository::Locally: Str:D :$prefix, CompUnit::Repository :$next-repo, *%args) { - my $abspath := $*SPEC.rel2abs($prefix); - my $IO := $abspath.IO; - - state %instances; - my $WHICH = self.^name ~ '|' ~ $abspath; - %instances{$WHICH} //= - self.bless(:prefix($IO), :lock(Lock.new), :$WHICH, :$next-repo, |%args); - } - - multi method Str(CompUnit::Repository::Locally:D:) { $!prefix.absolute } - multi method gist(CompUnit::Repository::Locally:D:) { - self.path-spec - } - multi method perl(CompUnit::Repository::Locally:D:) { - $?CLASS.perl ~ '.new(prefix => ' ~ $!prefix.absolute.perl ~ ')'; - } - - multi method WHICH(CompUnit::Repository::Locally:D:) { $!WHICH } - - method path-spec(CompUnit::Repository::Locally:D:) { - self.short-id ~ '#' ~ $!prefix.absolute; - } - - method source-file(Str $name --> IO::Path:D) { - self.prefix.add($name) - } - - method prefix { "{$!prefix}".IO } - - method id() { - my $name = self.path-spec; - $name ~= ',' ~ self.next-repo.id if self.next-repo; - return nqp::sha1($name); - } - - # stubs - method short-id(CompUnit::Repository::Locally:D:) {...} -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/Locally.pm6 rakudo-2018.03/src/core/CompUnit/Repository/Locally.pm6 --- rakudo-2018.02.1/src/core/CompUnit/Repository/Locally.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/Locally.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,46 @@ +role CompUnit::Repository::Locally { + has Lock $!lock; + has IO::Path $.prefix is required; + has Str $.WHICH; + + method new(CompUnit::Repository::Locally: Str:D :$prefix, CompUnit::Repository :$next-repo, *%args) { + my $abspath := $*SPEC.rel2abs($prefix); + my $IO := $abspath.IO; + + state %instances; + my $WHICH = self.^name ~ '|' ~ $abspath; + %instances{$WHICH} //= + self.bless(:prefix($IO), :lock(Lock.new), :$WHICH, :$next-repo, |%args); + } + + multi method Str(CompUnit::Repository::Locally:D:) { $!prefix.absolute } + multi method gist(CompUnit::Repository::Locally:D:) { + self.path-spec + } + multi method perl(CompUnit::Repository::Locally:D:) { + $?CLASS.perl ~ '.new(prefix => ' ~ $!prefix.absolute.perl ~ ')'; + } + + multi method WHICH(CompUnit::Repository::Locally:D:) { $!WHICH } + + method path-spec(CompUnit::Repository::Locally:D:) { + self.short-id ~ '#' ~ $!prefix.absolute; + } + + method source-file(Str $name --> IO::Path:D) { + self.prefix.add($name) + } + + method prefix { "{$!prefix}".IO } + + method id() { + my $name = self.path-spec; + $name ~= ',' ~ self.next-repo.id if self.next-repo; + return nqp::sha1($name); + } + + # stubs + method short-id(CompUnit::Repository::Locally:D:) {...} +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/NQP.pm rakudo-2018.03/src/core/CompUnit/Repository/NQP.pm --- rakudo-2018.02.1/src/core/CompUnit/Repository/NQP.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/NQP.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -class CompUnit::Repository::NQP does CompUnit::Repository { - method need( - CompUnit::DependencySpecification $spec, - CompUnit::PrecompilationRepository $precomp = self.precomp-repository(), - --> CompUnit:D) - { - if $spec.from eq 'NQP' { - my $nqp := nqp::gethllsym('perl6', 'ModuleLoader'); - - return CompUnit.new( - :short-name($spec.short-name), - :handle(CompUnit::Handle.new($nqp.load_module($spec.short-name, {:from}))), - :repo(self), - :repo-id($spec.short-name), - :from($spec.from), - ); - } - - return self.next-repo.need($spec, $precomp) if self.next-repo; - X::CompUnit::UnsatisfiedDependency.new(:specification($spec)).throw; - } - - method loaded() { - [] - } - - method id() { - 'NQP' - } - - method path-spec() { - 'nqp#' - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/NQP.pm6 rakudo-2018.03/src/core/CompUnit/Repository/NQP.pm6 --- rakudo-2018.02.1/src/core/CompUnit/Repository/NQP.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/NQP.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,36 @@ +class CompUnit::Repository::NQP does CompUnit::Repository { + method need( + CompUnit::DependencySpecification $spec, + CompUnit::PrecompilationRepository $precomp = self.precomp-repository(), + --> CompUnit:D) + { + if $spec.from eq 'NQP' { + my $nqp := nqp::gethllsym('perl6', 'ModuleLoader'); + + return CompUnit.new( + :short-name($spec.short-name), + :handle(CompUnit::Handle.new($nqp.load_module($spec.short-name, {:from}))), + :repo(self), + :repo-id($spec.short-name), + :from($spec.from), + ); + } + + return self.next-repo.need($spec, $precomp) if self.next-repo; + X::CompUnit::UnsatisfiedDependency.new(:specification($spec)).throw; + } + + method loaded() { + [] + } + + method id() { + 'NQP' + } + + method path-spec() { + 'nqp#' + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/Perl5.pm rakudo-2018.03/src/core/CompUnit/Repository/Perl5.pm --- rakudo-2018.02.1/src/core/CompUnit/Repository/Perl5.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/Perl5.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -class CompUnit::Repository::Perl5 does CompUnit::Repository { - method need( - CompUnit::DependencySpecification $spec, - CompUnit::PrecompilationRepository $precomp = self.precomp-repository(), - --> CompUnit:D) - { - if $spec.from eq 'Perl5' { - require Inline::Perl5; - my $perl5 = ::('Inline::Perl5').default_perl5; - - if $*RAKUDO_MODULE_DEBUG -> $RMD { - $RMD("Loading {$spec.short-name} via Inline::Perl5"); - } - my $handle := $perl5.require( - $spec.short-name, - $spec.version-matcher !== True ?? $spec.version-matcher.Num !! Num, - :handle - ); - return CompUnit.new( - :short-name($spec.short-name), - :$handle, - :repo(self), - :repo-id($spec.short-name), - :from($spec.from), - ); - - CATCH { - when X::CompUnit::UnsatisfiedDependency { - X::NYI::Available.new(:available('Inline::Perl5'), :feature('Perl 5')).throw; - } - } - } - - return self.next-repo.need($spec, $precomp) if self.next-repo; - X::CompUnit::UnsatisfiedDependency.new(:specification($spec)).throw; - } - - method loaded() { - [] - } - - method id() { - 'Perl5' - } - - method path-spec() { - 'perl5#' - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/Perl5.pm6 rakudo-2018.03/src/core/CompUnit/Repository/Perl5.pm6 --- rakudo-2018.02.1/src/core/CompUnit/Repository/Perl5.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/Perl5.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,51 @@ +class CompUnit::Repository::Perl5 does CompUnit::Repository { + method need( + CompUnit::DependencySpecification $spec, + CompUnit::PrecompilationRepository $precomp = self.precomp-repository(), + --> CompUnit:D) + { + if $spec.from eq 'Perl5' { + require Inline::Perl5; + my $perl5 = ::('Inline::Perl5').default_perl5; + + if $*RAKUDO_MODULE_DEBUG -> $RMD { + $RMD("Loading {$spec.short-name} via Inline::Perl5"); + } + my $handle := $perl5.require( + $spec.short-name, + $spec.version-matcher !== True ?? $spec.version-matcher.Num !! Num, + :handle + ); + return CompUnit.new( + :short-name($spec.short-name), + :$handle, + :repo(self), + :repo-id($spec.short-name), + :from($spec.from), + ); + + CATCH { + when X::CompUnit::UnsatisfiedDependency { + X::NYI::Available.new(:available('Inline::Perl5'), :feature('Perl 5')).throw; + } + } + } + + return self.next-repo.need($spec, $precomp) if self.next-repo; + X::CompUnit::UnsatisfiedDependency.new(:specification($spec)).throw; + } + + method loaded() { + [] + } + + method id() { + 'Perl5' + } + + method path-spec() { + 'perl5#' + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/Spec.pm rakudo-2018.03/src/core/CompUnit/Repository/Spec.pm --- rakudo-2018.02.1/src/core/CompUnit/Repository/Spec.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/Spec.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,38 +0,0 @@ -class CompUnit::Repository::Spec { - has $.short-id; - has %.options; - has $.path; - has $.Str; - method from-string(Str:D $spec, :$default-short-id = 'file') { - return unless $spec.chars; - # something we understand - if $spec.contains('#') { - if $spec ~~ /^ - - [ - $=[ <.ident>+ % '::' ] - $=[ '#' $=\w+ - <[ < ( [ { ]> $=<[\w-]>+? <[ > ) \] } ]> - ]* - '#' - ]? - $=.* - $/ { - my $short-id := ~($ // $default-short-id); - my $path := $*SPEC.canonpath(~$); - self.new( - :$short-id, - :options(%($>>.Str Z=> $>>.Str)), - :$path - :Str($short-id ~ $ ~ '#' ~ $path) - ); - } - } - else { - my $path := $*SPEC.canonpath($spec); - self.new(:short-id($default-short-id), :$path, :Str($default-short-id ~ '#' ~ $path)) - } - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/Spec.pm6 rakudo-2018.03/src/core/CompUnit/Repository/Spec.pm6 --- rakudo-2018.02.1/src/core/CompUnit/Repository/Spec.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/Spec.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,38 @@ +class CompUnit::Repository::Spec { + has $.short-id; + has %.options; + has $.path; + has $.Str; + method from-string(Str:D $spec, :$default-short-id = 'file') { + return unless $spec.chars; + # something we understand + if $spec.contains('#') { + if $spec ~~ /^ + + [ + $=[ <.ident>+ % '::' ] + $=[ '#' $=\w+ + <[ < ( [ { ]> $=<[\w-]>+? <[ > ) \] } ]> + ]* + '#' + ]? + $=.* + $/ { + my $short-id := ~($ // $default-short-id); + my $path := $*SPEC.canonpath(~$); + self.new( + :$short-id, + :options(%($>>.Str Z=> $>>.Str)), + :$path + :Str($short-id ~ $ ~ '#' ~ $path) + ); + } + } + else { + my $path := $*SPEC.canonpath($spec); + self.new(:short-id($default-short-id), :$path, :Str($default-short-id ~ '#' ~ $path)) + } + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/Unknown.pm rakudo-2018.03/src/core/CompUnit/Repository/Unknown.pm --- rakudo-2018.02.1/src/core/CompUnit/Repository/Unknown.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/Unknown.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -class CompUnit::Repository::Unknown does CompUnit::Repository { - has $.path-spec; - has $.short-name; - - method need( - CompUnit::DependencySpecification $spec, - CompUnit::PrecompilationRepository $precomp?, - CompUnit::PrecompilationStore :@precomp-stores = Array[CompUnit::PrecompilationStore].new( - self.repo-chain.map(*.precomp-store).grep(*.defined) - ), - --> CompUnit:D) - { - return $precomp - ?? self.next-repo.need($spec, $precomp, :@precomp-stores) - !! self.next-repo.need($spec, :@precomp-stores) - if self.next-repo; - X::CompUnit::UnsatisfiedDependency.new(:specification($spec)).throw; - } - - method loaded() { - [] - } - - method id() { - $.path-spec - } - - method Str() { self.^name ~ " $.short-name $.path-spec" } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository/Unknown.pm6 rakudo-2018.03/src/core/CompUnit/Repository/Unknown.pm6 --- rakudo-2018.02.1/src/core/CompUnit/Repository/Unknown.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository/Unknown.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,31 @@ +class CompUnit::Repository::Unknown does CompUnit::Repository { + has $.path-spec; + has $.short-name; + + method need( + CompUnit::DependencySpecification $spec, + CompUnit::PrecompilationRepository $precomp?, + CompUnit::PrecompilationStore :@precomp-stores = Array[CompUnit::PrecompilationStore].new( + self.repo-chain.map(*.precomp-store).grep(*.defined) + ), + --> CompUnit:D) + { + return $precomp + ?? self.next-repo.need($spec, $precomp, :@precomp-stores) + !! self.next-repo.need($spec, :@precomp-stores) + if self.next-repo; + X::CompUnit::UnsatisfiedDependency.new(:specification($spec)).throw; + } + + method loaded() { + [] + } + + method id() { + $.path-spec + } + + method Str() { self.^name ~ " $.short-name $.path-spec" } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository.pm rakudo-2018.03/src/core/CompUnit/Repository.pm --- rakudo-2018.02.1/src/core/CompUnit/Repository.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -role CompUnit::Repository { - has CompUnit::Repository $.next-repo is rw; - - # Resolves a dependency specification to a concrete dependency. If the - # dependency was not already loaded, loads it. Returns a CompUnit - # object that represents the selected dependency. If there is no - # matching dependency, throws X::CompUnit::UnsatisfiedDependency. - method need(CompUnit::DependencySpecification $spec, - # If we're first in the chain, our precomp repo is the chosen one. - CompUnit::PrecompilationRepository $precomp = self.precomp-repository(), - CompUnit::PrecompilationStore :@precomp-stores = Array[CompUnit::PrecompilationStore].new($precomp.store) - --> CompUnit:D) - { ... } - - # Resolves a dependency specification to a concrete dependency. - # Returns a CompUnit object that represents the selected dependency. - # If there is no matching dependency, Nil is returned. - method resolve(CompUnit::DependencySpecification $spec --> CompUnit:D) - { - self.next-repo - ?? self.next-repo.resolve($spec) - !! Nil - } - - # Just load the file and return a CompUnit object representing it. - method load(IO::Path:D $file --> CompUnit:D) - { - self.next-repo - ?? self.next-repo.load($file) - !! nqp::die("Could not find $file in:\n" - ~ $*REPO.repo-chain.map(*.Str).join("\n").indent(4)); - } - - # Returns the CompUnit objects describing all of the compilation - # units that have been loaded by this repository in the current - # process. - method loaded(--> Iterable:D) - { ... } - - # Returns a unique ID of this repository - method id(--> Str:D) - { ... } - - method precomp-store(--> CompUnit::PrecompilationStore) - { CompUnit::PrecompilationStore } - - method precomp-repository(--> CompUnit::PrecompilationRepository) - { CompUnit::PrecompilationRepository::None } - - method repo-chain() { - ($.next-repo and $.next-repo.defined) ?? (self, |$.next-repo.repo-chain()) !! (self, ); - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/Repository.pm6 rakudo-2018.03/src/core/CompUnit/Repository.pm6 --- rakudo-2018.02.1/src/core/CompUnit/Repository.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/Repository.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,55 @@ +role CompUnit::Repository { + has CompUnit::Repository $.next-repo is rw; + + # Resolves a dependency specification to a concrete dependency. If the + # dependency was not already loaded, loads it. Returns a CompUnit + # object that represents the selected dependency. If there is no + # matching dependency, throws X::CompUnit::UnsatisfiedDependency. + method need(CompUnit::DependencySpecification $spec, + # If we're first in the chain, our precomp repo is the chosen one. + CompUnit::PrecompilationRepository $precomp = self.precomp-repository(), + CompUnit::PrecompilationStore :@precomp-stores = Array[CompUnit::PrecompilationStore].new($precomp.store) + --> CompUnit:D) + { ... } + + # Resolves a dependency specification to a concrete dependency. + # Returns a CompUnit object that represents the selected dependency. + # If there is no matching dependency, Nil is returned. + method resolve(CompUnit::DependencySpecification $spec --> CompUnit:D) + { + self.next-repo + ?? self.next-repo.resolve($spec) + !! Nil + } + + # Just load the file and return a CompUnit object representing it. + method load(IO::Path:D $file --> CompUnit:D) + { + self.next-repo + ?? self.next-repo.load($file) + !! nqp::die("Could not find $file in:\n" + ~ $*REPO.repo-chain.map(*.Str).join("\n").indent(4)); + } + + # Returns the CompUnit objects describing all of the compilation + # units that have been loaded by this repository in the current + # process. + method loaded(--> Iterable:D) + { ... } + + # Returns a unique ID of this repository + method id(--> Str:D) + { ... } + + method precomp-store(--> CompUnit::PrecompilationStore) + { CompUnit::PrecompilationStore } + + method precomp-repository(--> CompUnit::PrecompilationRepository) + { CompUnit::PrecompilationRepository::None } + + method repo-chain() { + ($.next-repo and $.next-repo.defined) ?? (self, |$.next-repo.repo-chain()) !! (self, ); + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/RepositoryRegistry.pm rakudo-2018.03/src/core/CompUnit/RepositoryRegistry.pm --- rakudo-2018.02.1/src/core/CompUnit/RepositoryRegistry.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/RepositoryRegistry.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,409 +0,0 @@ -class CompUnit::Repository::FileSystem { ... } -class CompUnit::Repository::Installation { ... } -class CompUnit::Repository::AbsolutePath { ... } -class CompUnit::Repository::Unknown { ... } -class CompUnit::Repository::NQP { ... } -class CompUnit::Repository::Perl5 { ... } - -#?if jvm -class CompUnit::Repository::JavaRuntime { ... } -#?endif - -class CompUnit::RepositoryRegistry { - my $lock = Lock.new; - my %include-spec2cur; - - proto method repository-for-spec(|) { * } - multi method repository-for-spec(Str $spec, CompUnit::Repository :$next-repo) { - self.repository-for-spec(CompUnit::Repository::Spec.from-string($spec), :$next-repo) - } - multi method repository-for-spec(CompUnit::Repository::Spec $spec, CompUnit::Repository :$next-repo) { - my $short-id := $spec.short-id; - my %options := $spec.options; - my $path := $spec.path; - - my $class := short-id2class($short-id); - return CompUnit::Repository::Unknown.new(:path-spec($spec), :short-name($short-id)) - if so $class && nqp::istype($class, Failure) or !nqp::istype($class, CompUnit::Repository); - - my $abspath = $class.?absolutify($path) // $path; - my $id = "$short-id#$abspath"; - %options = $next-repo if $next-repo; - $lock.protect( { - %include-spec2cur{$id}:exists - ?? %include-spec2cur{$id} - !! (%include-spec2cur{$id} := $class.new(:prefix($abspath), |%options)); - } ); - } - - method !register-repository($id, CompUnit::Repository $repo) { - $lock.protect( { - %include-spec2cur{$id}:exists - ?? %include-spec2cur{$id} - !! (%include-spec2cur{$id} := $repo); - } ); - } - - my $custom-lib := nqp::hash(); - method setup-repositories() { - my $raw-specs; - # only look up environment once - my $ENV := nqp::getattr(%*ENV,Map,'$!storage'); - - # starting up for creating precomp - my $precomp-specs = nqp::existskey($ENV,'RAKUDO_PRECOMP_WITH') - ?? nqp::atkey($ENV,'RAKUDO_PRECOMP_WITH') - !! False; - if $precomp-specs { - # assume well formed strings - $raw-specs := nqp::split(',', $precomp-specs); - } - - # normal start up - else { - $raw-specs := nqp::list(); - for Rakudo::Internals.INCLUDE -> $specs { - nqp::push($raw-specs,$_) - for parse-include-specS($specs); - } - - if nqp::existskey($ENV,'RAKUDOLIB') { - nqp::push($raw-specs,$_) - for parse-include-specS(nqp::atkey($ENV,'RAKUDOLIB')); - } - if nqp::existskey($ENV,'PERL6LIB') { - nqp::push($raw-specs,$_) - for parse-include-specS(nqp::atkey($ENV,'PERL6LIB')); - } - } - - my $prefix := nqp::existskey($ENV,'RAKUDO_PREFIX') - ?? nqp::atkey($ENV,'RAKUDO_PREFIX') - !! nqp::concat( - nqp::atkey(nqp::getcomp('perl6').config,'libdir'), - '/perl6' - ); - - # XXX Various issues with this stuff on JVM , TEMPORARY - my str $home; - try { - if nqp::existskey($ENV,'HOME') - ?? nqp::atkey($ENV,'HOME') - !! nqp::concat( - (nqp::existskey($ENV,'HOMEDRIVE') - ?? nqp::atkey($ENV,'HOMEDRIVE') !! ''), - (nqp::existskey($ENV,'HOMEPATH') - ?? nqp::atkey($ENV,'HOMEPATH') !! '') - ) -> $home-path { - $home = "$home-path/.perl6"; - my str $path = "inst#$home"; - } - } - - # set up custom libs - my str $site = "inst#$prefix/site"; - my str $vendor = "inst#$prefix/vendor"; - my str $perl = "inst#$prefix"; - - # your basic repo chain - my CompUnit::Repository $next-repo := - $precomp-specs - ?? CompUnit::Repository - !! CompUnit::Repository::AbsolutePath.new( - :next-repo( CompUnit::Repository::NQP.new( - :next-repo(CompUnit::Repository::Perl5.new( -#?if jvm - :next-repo(CompUnit::Repository::JavaRuntime.new) -#?endif - )) - ) - ) - ); - - # create reverted, unique list of path-specs - my $iter := nqp::iterator($raw-specs); - my $unique := nqp::hash(); - my $specs := nqp::list(); - while $iter { - my $repo-spec := nqp::shift($iter); - my str $path-spec = $repo-spec.Str; - unless nqp::existskey($unique,$path-spec) { - nqp::bindkey($unique,$path-spec,1); - nqp::unshift($specs,$repo-spec); - } - } - - unless $precomp-specs { - nqp::bindkey($custom-lib, 'perl', $next-repo := self!register-repository( - $perl, - CompUnit::Repository::Installation.new(:prefix($prefix), :$next-repo) - )) unless nqp::existskey($unique, $perl); - nqp::bindkey($custom-lib, 'vendor', $next-repo := self!register-repository( - $vendor, - CompUnit::Repository::Installation.new(:prefix("$prefix/vendor"), :$next-repo) - )) unless nqp::existskey($unique, $vendor); - nqp::bindkey($custom-lib, 'site', $next-repo := self!register-repository( - $site, - CompUnit::Repository::Installation.new(:prefix("$prefix/site"), :$next-repo) - )) unless nqp::existskey($unique, $site); - nqp::bindkey($custom-lib, 'home', $next-repo := self!register-repository( - "inst#$home/.perl6", - CompUnit::Repository::Installation.new(:prefix($home), :$next-repo) - )) if $home and not nqp::existskey($unique, $home); - } - - # convert repo-specs to repos - my $repos := nqp::hash(); - $iter := nqp::iterator($specs); - while $iter { - my $spec = nqp::shift($iter); - $next-repo := self.use-repository( - self.repository-for-spec($spec), :current($next-repo)); - nqp::bindkey($repos,$spec.Str,$next-repo); - } - - # register manually set custom-lib repos - unless nqp::existskey($custom-lib, 'perl') { - my $repo := nqp::atkey($repos, $perl); - if nqp::isnull($repo) { - nqp::deletekey($custom-lib, 'perl'); - } - else { - nqp::bindkey($custom-lib, 'perl', $repo); - } - } - unless nqp::existskey($custom-lib, 'vendor') { - my $repo := nqp::atkey($repos, $vendor); - if nqp::isnull($repo) { - nqp::deletekey($custom-lib, 'vendor'); - } - else { - nqp::bindkey($custom-lib, 'vendor', $repo); - } - } - unless nqp::existskey($custom-lib, 'site') { - my $repo := nqp::atkey($repos, $site); - if nqp::isnull($repo) { - nqp::deletekey($custom-lib, 'site'); - } - else { - nqp::bindkey($custom-lib, 'site', $repo); - } - } - unless nqp::existskey($custom-lib, 'home') { - my $repo := nqp::atkey($repos, $home); - if nqp::isnull($repo) { - nqp::deletekey($custom-lib, 'home'); - } - else { - nqp::bindkey($custom-lib, 'home', $repo); - } - } - - $next-repo - } - - method !remove-from-chain(CompUnit::Repository $repo, CompUnit::Repository :$current = $*REPO) { - my $item = $current; - while $item { - if $item.next-repo === $repo { - $item.next-repo = $repo.next-repo; - last; - } - $item = $item.next-repo; - } - } - - method use-repository(CompUnit::Repository $repo, CompUnit::Repository :$current = $*REPO) { - return $repo if $current === $repo; - self!remove-from-chain($repo, :$current); - $repo.next-repo = $current; - PROCESS::<$REPO> := $repo; - } - - method repository-for-name(Str:D \name) { - $*REPO; # initialize if not yet done - my str $name = nqp::unbox_s(name); - nqp::existskey($custom-lib,$name) - ?? nqp::atkey($custom-lib,$name) - !! Nil - } - - method register-name($name, CompUnit::Repository $repo) { - nqp::bindkey($custom-lib, $name, $repo); - } - - method name-for-repository(CompUnit::Repository $repo) { - $*REPO; # initialize if not yet done - my $iter := nqp::iterator($custom-lib); - while $iter { - my \pair = nqp::shift($iter); - return nqp::iterkey_s(pair) if nqp::iterval(pair).prefix eq $repo.prefix; - } - Nil - } - - method file-for-spec(Str $spec) { - my @parts = $spec.split('#', 2); - if @parts.elems == 2 { - my $repo = self.repository-for-name(@parts[0]); - return $repo.source-file(@parts[1]) if $repo.can('source-file'); - } - Nil - } - - method run-script($script, :$dist-name, :$name is copy, :$auth, :$ver) { - shift @*ARGS if $name; - shift @*ARGS if $auth; - shift @*ARGS if $ver; - $name //= $dist-name; - my @installations = $*REPO.repo-chain.grep(CompUnit::Repository::Installation); - my @binaries = @installations.map({ .script("bin/$script", :$name, :$auth, :$ver) }).grep(*.defined); - unless +@binaries { - @binaries = flat @installations.map: { .script("bin/$script", :$name) }; - if +@binaries { - note "===SORRY!===\n" - ~ "No candidate found for '$script' that match your criteria.\n" - ~ "Did you perhaps mean one of these?"; - my %caps = :name(['Distribution', 12]), :auth(['Author(ity)', 11]), :ver(['Version', 7]); - for @binaries -> $dist { - for %caps.kv -> $caption, @opts { - @opts[1] = max @opts[1], ($dist{$caption} // '').Str.chars - } - } - note ' ' ~ %caps.values.map({ sprintf('%-*s', .[1], .[0]) }).join(' | '); - for @binaries -> $dist { - note ' ' ~ %caps.kv.map( -> $k, $v { sprintf('%-*s', $v.[1], $dist{$k} // '') } ).join(' | ') - } - } - else { - note "===SORRY!===\nNo candidate found for '$script'.\n"; - } - exit 1; - } - - my $bin = @binaries[0]; - require "$bin"; - } - - method head() { # mostly usefull for access from NQP - $*REPO - } - - method resolve-unknown-repos($repo is copy) { - # Cannot just use GLOBAL.WHO here as that gives a BOOTHash - my $global := nqp::list("GLOBAL"); - my $prev-repo; - while defined $repo { - if nqp::istype($repo, CompUnit::Repository::Unknown) { - my $next-repo := $repo.next-repo; - - my $head := PROCESS<$REPO>; - PROCESS::<$REPO> := $next-repo; - my $comp_unit = $next-repo.need( - CompUnit::DependencySpecification.new(:short-name($repo.short-name)) - ); - PROCESS::<$REPO> := $head; - - $*W.find_symbol($global).WHO.merge-symbols($comp_unit.handle.globalish-package); - $repo = self.repository-for-spec($repo.path-spec, :$next-repo); - if defined $prev-repo { - $prev-repo.next-repo = $repo; - } - else { - PROCESS::<$REPO> := nqp::decont($repo); - } - } - $prev-repo = $repo; - $repo = $repo.next-repo; - } - } - - # Handles any object repossession conflicts that occurred during module load, - # or complains about any that cannot be resolved. - method resolve_repossession_conflicts(@conflicts) { - for @conflicts -> $orig is raw, $current is raw { - # If it's a Stash in conflict, we make sure any original entries get - # appropriately copied. - if $orig.HOW.name($orig) eq 'Stash' { - $current.merge-symbols($orig); - } - # We could complain about anything else, and may in the future; for - # now, we let it pass by with "latest wins" semantics. - } - } - - sub short-id2class(Str:D $short-id) { - state %short-id2class; - state $lock = Lock.new; - - Proxy.new( - FETCH => { - $lock.protect( { - if %short-id2class.EXISTS-KEY($short-id) { - %short-id2class.AT-KEY($short-id); - } - else { - my $type = try ::($short-id); - if $type !=== Any { - if $type.?short-id -> $id { - if %short-id2class.EXISTS-KEY($id) { - %short-id2class.AT-KEY($id); - } - else { - %short-id2class.BIND-KEY($id, $type); - } - } - else { - die "Class '$type.^name()' is not a CompUnit::Repository"; - } - } - else { - Any - } - } - } ); - }, - STORE => -> $, $class { - my $type = ::($class); - die "Must load class '$class' first" if nqp::istype($type,Failure); - $lock.protect( { %short-id2class{$short-id} := $type } ); - }, - ); - } - -# prime the short-id -> class lookup - short-id2class('file') = 'CompUnit::Repository::FileSystem'; - short-id2class('inst') = 'CompUnit::Repository::Installation'; - short-id2class('ap') = 'CompUnit::Repository::AbsolutePath'; - short-id2class('nqp') = 'CompUnit::Repository::NQP'; - short-id2class('perl5') = 'CompUnit::Repository::Perl5'; -#?if jvm - short-id2class('javart') = 'CompUnit::Repository::JavaRuntime'; - short-id2class('java') = 'CompUnit::Repository::Java'; -#?endif - - sub parse-include-specS(Str:D $specs) { - my @found; - my $default-short-id = 'file'; - - if $*RAKUDO_MODULE_DEBUG -> $RMD { $RMD("Parsing specs: $specs") } - - # for all possible specs - my $spec-list := nqp::split(',', $specs); - my $iter := nqp::iterator($spec-list); - while $iter { - my $spec := nqp::shift($iter); - if CompUnit::Repository::Spec.from-string($spec.trim, :$default-short-id) -> $repo-spec { - @found.push: $repo-spec; - $default-short-id = $repo-spec.short-id; - } - elsif $spec { - die "Don't know how to handle $spec"; - } - } - @found; - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit/RepositoryRegistry.pm6 rakudo-2018.03/src/core/CompUnit/RepositoryRegistry.pm6 --- rakudo-2018.02.1/src/core/CompUnit/RepositoryRegistry.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit/RepositoryRegistry.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,409 @@ +class CompUnit::Repository::FileSystem { ... } +class CompUnit::Repository::Installation { ... } +class CompUnit::Repository::AbsolutePath { ... } +class CompUnit::Repository::Unknown { ... } +class CompUnit::Repository::NQP { ... } +class CompUnit::Repository::Perl5 { ... } + +#?if jvm +class CompUnit::Repository::JavaRuntime { ... } +#?endif + +class CompUnit::RepositoryRegistry { + my $lock = Lock.new; + my %include-spec2cur; + + proto method repository-for-spec(|) { * } + multi method repository-for-spec(Str $spec, CompUnit::Repository :$next-repo) { + self.repository-for-spec(CompUnit::Repository::Spec.from-string($spec), :$next-repo) + } + multi method repository-for-spec(CompUnit::Repository::Spec $spec, CompUnit::Repository :$next-repo) { + my $short-id := $spec.short-id; + my %options := $spec.options; + my $path := $spec.path; + + my $class := short-id2class($short-id); + return CompUnit::Repository::Unknown.new(:path-spec($spec), :short-name($short-id)) + if so $class && nqp::istype($class, Failure) or !nqp::istype($class, CompUnit::Repository); + + my $abspath = $class.?absolutify($path) // $path; + my $id = "$short-id#$abspath"; + %options = $next-repo if $next-repo; + $lock.protect( { + %include-spec2cur{$id}:exists + ?? %include-spec2cur{$id} + !! (%include-spec2cur{$id} := $class.new(:prefix($abspath), |%options)); + } ); + } + + method !register-repository($id, CompUnit::Repository $repo) { + $lock.protect( { + %include-spec2cur{$id}:exists + ?? %include-spec2cur{$id} + !! (%include-spec2cur{$id} := $repo); + } ); + } + + my $custom-lib := nqp::hash(); + method setup-repositories() { + my $raw-specs; + # only look up environment once + my $ENV := nqp::getattr(%*ENV,Map,'$!storage'); + + # starting up for creating precomp + my $precomp-specs = nqp::existskey($ENV,'RAKUDO_PRECOMP_WITH') + ?? nqp::atkey($ENV,'RAKUDO_PRECOMP_WITH') + !! False; + if $precomp-specs { + # assume well formed strings + $raw-specs := nqp::split(',', $precomp-specs); + } + + # normal start up + else { + $raw-specs := nqp::list(); + for Rakudo::Internals.INCLUDE -> $specs { + nqp::push($raw-specs,$_) + for parse-include-specS($specs); + } + + if nqp::existskey($ENV,'RAKUDOLIB') { + nqp::push($raw-specs,$_) + for parse-include-specS(nqp::atkey($ENV,'RAKUDOLIB')); + } + if nqp::existskey($ENV,'PERL6LIB') { + nqp::push($raw-specs,$_) + for parse-include-specS(nqp::atkey($ENV,'PERL6LIB')); + } + } + + my $prefix := nqp::existskey($ENV,'RAKUDO_PREFIX') + ?? nqp::atkey($ENV,'RAKUDO_PREFIX') + !! nqp::concat( + nqp::atkey(nqp::getcomp('perl6').config,'libdir'), + '/perl6' + ); + + # XXX Various issues with this stuff on JVM , TEMPORARY + my str $home; + try { + if nqp::existskey($ENV,'HOME') + ?? nqp::atkey($ENV,'HOME') + !! nqp::concat( + (nqp::existskey($ENV,'HOMEDRIVE') + ?? nqp::atkey($ENV,'HOMEDRIVE') !! ''), + (nqp::existskey($ENV,'HOMEPATH') + ?? nqp::atkey($ENV,'HOMEPATH') !! '') + ) -> $home-path { + $home = "$home-path/.perl6"; + my str $path = "inst#$home"; + } + } + + # set up custom libs + my str $site = "inst#$prefix/site"; + my str $vendor = "inst#$prefix/vendor"; + my str $perl = "inst#$prefix"; + + # your basic repo chain + my CompUnit::Repository $next-repo := + $precomp-specs + ?? CompUnit::Repository + !! CompUnit::Repository::AbsolutePath.new( + :next-repo( CompUnit::Repository::NQP.new( + :next-repo(CompUnit::Repository::Perl5.new( +#?if jvm + :next-repo(CompUnit::Repository::JavaRuntime.new) +#?endif + )) + ) + ) + ); + + # create reverted, unique list of path-specs + my $iter := nqp::iterator($raw-specs); + my $unique := nqp::hash(); + my $specs := nqp::list(); + while $iter { + my $repo-spec := nqp::shift($iter); + my str $path-spec = $repo-spec.Str; + unless nqp::existskey($unique,$path-spec) { + nqp::bindkey($unique,$path-spec,1); + nqp::unshift($specs,$repo-spec); + } + } + + unless $precomp-specs { + nqp::bindkey($custom-lib, 'perl', $next-repo := self!register-repository( + $perl, + CompUnit::Repository::Installation.new(:prefix($prefix), :$next-repo) + )) unless nqp::existskey($unique, $perl); + nqp::bindkey($custom-lib, 'vendor', $next-repo := self!register-repository( + $vendor, + CompUnit::Repository::Installation.new(:prefix("$prefix/vendor"), :$next-repo) + )) unless nqp::existskey($unique, $vendor); + nqp::bindkey($custom-lib, 'site', $next-repo := self!register-repository( + $site, + CompUnit::Repository::Installation.new(:prefix("$prefix/site"), :$next-repo) + )) unless nqp::existskey($unique, $site); + nqp::bindkey($custom-lib, 'home', $next-repo := self!register-repository( + "inst#$home/.perl6", + CompUnit::Repository::Installation.new(:prefix($home), :$next-repo) + )) if $home and not nqp::existskey($unique, $home); + } + + # convert repo-specs to repos + my $repos := nqp::hash(); + $iter := nqp::iterator($specs); + while $iter { + my $spec = nqp::shift($iter); + $next-repo := self.use-repository( + self.repository-for-spec($spec), :current($next-repo)); + nqp::bindkey($repos,$spec.Str,$next-repo); + } + + # register manually set custom-lib repos + unless nqp::existskey($custom-lib, 'perl') { + my $repo := nqp::atkey($repos, $perl); + if nqp::isnull($repo) { + nqp::deletekey($custom-lib, 'perl'); + } + else { + nqp::bindkey($custom-lib, 'perl', $repo); + } + } + unless nqp::existskey($custom-lib, 'vendor') { + my $repo := nqp::atkey($repos, $vendor); + if nqp::isnull($repo) { + nqp::deletekey($custom-lib, 'vendor'); + } + else { + nqp::bindkey($custom-lib, 'vendor', $repo); + } + } + unless nqp::existskey($custom-lib, 'site') { + my $repo := nqp::atkey($repos, $site); + if nqp::isnull($repo) { + nqp::deletekey($custom-lib, 'site'); + } + else { + nqp::bindkey($custom-lib, 'site', $repo); + } + } + unless nqp::existskey($custom-lib, 'home') { + my $repo := nqp::atkey($repos, $home); + if nqp::isnull($repo) { + nqp::deletekey($custom-lib, 'home'); + } + else { + nqp::bindkey($custom-lib, 'home', $repo); + } + } + + $next-repo + } + + method !remove-from-chain(CompUnit::Repository $repo, CompUnit::Repository :$current = $*REPO) { + my $item = $current; + while $item { + if $item.next-repo === $repo { + $item.next-repo = $repo.next-repo; + last; + } + $item = $item.next-repo; + } + } + + method use-repository(CompUnit::Repository $repo, CompUnit::Repository :$current = $*REPO) { + return $repo if $current === $repo; + self!remove-from-chain($repo, :$current); + $repo.next-repo = $current; + PROCESS::<$REPO> := $repo; + } + + method repository-for-name(Str:D \name) { + $*REPO; # initialize if not yet done + my str $name = nqp::unbox_s(name); + nqp::existskey($custom-lib,$name) + ?? nqp::atkey($custom-lib,$name) + !! Nil + } + + method register-name($name, CompUnit::Repository $repo) { + nqp::bindkey($custom-lib, $name, $repo); + } + + method name-for-repository(CompUnit::Repository $repo) { + $*REPO; # initialize if not yet done + my $iter := nqp::iterator($custom-lib); + while $iter { + my \pair = nqp::shift($iter); + return nqp::iterkey_s(pair) if nqp::iterval(pair).prefix eq $repo.prefix; + } + Nil + } + + method file-for-spec(Str $spec) { + my @parts = $spec.split('#', 2); + if @parts.elems == 2 { + my $repo = self.repository-for-name(@parts[0]); + return $repo.source-file(@parts[1]) if $repo.can('source-file'); + } + Nil + } + + method run-script($script, :$dist-name, :$name is copy, :$auth, :$ver) { + shift @*ARGS if $name; + shift @*ARGS if $auth; + shift @*ARGS if $ver; + $name //= $dist-name; + my @installations = $*REPO.repo-chain.grep(CompUnit::Repository::Installation); + my @binaries = @installations.map({ .script("bin/$script", :$name, :$auth, :$ver) }).grep(*.defined); + unless +@binaries { + @binaries = flat @installations.map: { .script("bin/$script", :$name) }; + if +@binaries { + note "===SORRY!===\n" + ~ "No candidate found for '$script' that match your criteria.\n" + ~ "Did you perhaps mean one of these?"; + my %caps = :name(['Distribution', 12]), :auth(['Author(ity)', 11]), :ver(['Version', 7]); + for @binaries -> $dist { + for %caps.kv -> $caption, @opts { + @opts[1] = max @opts[1], ($dist{$caption} // '').Str.chars + } + } + note ' ' ~ %caps.values.map({ sprintf('%-*s', .[1], .[0]) }).join(' | '); + for @binaries -> $dist { + note ' ' ~ %caps.kv.map( -> $k, $v { sprintf('%-*s', $v.[1], $dist{$k} // '') } ).join(' | ') + } + } + else { + note "===SORRY!===\nNo candidate found for '$script'.\n"; + } + exit 1; + } + + my $bin = @binaries[0]; + require "$bin"; + } + + method head() { # mostly usefull for access from NQP + $*REPO + } + + method resolve-unknown-repos($repo is copy) { + # Cannot just use GLOBAL.WHO here as that gives a BOOTHash + my $global := nqp::list("GLOBAL"); + my $prev-repo; + while defined $repo { + if nqp::istype($repo, CompUnit::Repository::Unknown) { + my $next-repo := $repo.next-repo; + + my $head := PROCESS<$REPO>; + PROCESS::<$REPO> := $next-repo; + my $comp_unit = $next-repo.need( + CompUnit::DependencySpecification.new(:short-name($repo.short-name)) + ); + PROCESS::<$REPO> := $head; + + $*W.find_symbol($global).WHO.merge-symbols($comp_unit.handle.globalish-package); + $repo = self.repository-for-spec($repo.path-spec, :$next-repo); + if defined $prev-repo { + $prev-repo.next-repo = $repo; + } + else { + PROCESS::<$REPO> := nqp::decont($repo); + } + } + $prev-repo = $repo; + $repo = $repo.next-repo; + } + } + + # Handles any object repossession conflicts that occurred during module load, + # or complains about any that cannot be resolved. + method resolve_repossession_conflicts(@conflicts) { + for @conflicts -> $orig is raw, $current is raw { + # If it's a Stash in conflict, we make sure any original entries get + # appropriately copied. + if $orig.HOW.name($orig) eq 'Stash' { + $current.merge-symbols($orig); + } + # We could complain about anything else, and may in the future; for + # now, we let it pass by with "latest wins" semantics. + } + } + + sub short-id2class(Str:D $short-id) { + state %short-id2class; + state $lock = Lock.new; + + Proxy.new( + FETCH => { + $lock.protect( { + if %short-id2class.EXISTS-KEY($short-id) { + %short-id2class.AT-KEY($short-id); + } + else { + my $type = try ::($short-id); + if $type !=== Any { + if $type.?short-id -> $id { + if %short-id2class.EXISTS-KEY($id) { + %short-id2class.AT-KEY($id); + } + else { + %short-id2class.BIND-KEY($id, $type); + } + } + else { + die "Class '$type.^name()' is not a CompUnit::Repository"; + } + } + else { + Any + } + } + } ); + }, + STORE => -> $, $class { + my $type = ::($class); + die "Must load class '$class' first" if nqp::istype($type,Failure); + $lock.protect( { %short-id2class{$short-id} := $type } ); + }, + ); + } + +# prime the short-id -> class lookup + short-id2class('file') = 'CompUnit::Repository::FileSystem'; + short-id2class('inst') = 'CompUnit::Repository::Installation'; + short-id2class('ap') = 'CompUnit::Repository::AbsolutePath'; + short-id2class('nqp') = 'CompUnit::Repository::NQP'; + short-id2class('perl5') = 'CompUnit::Repository::Perl5'; +#?if jvm + short-id2class('javart') = 'CompUnit::Repository::JavaRuntime'; + short-id2class('java') = 'CompUnit::Repository::Java'; +#?endif + + sub parse-include-specS(Str:D $specs) { + my @found; + my $default-short-id = 'file'; + + if $*RAKUDO_MODULE_DEBUG -> $RMD { $RMD("Parsing specs: $specs") } + + # for all possible specs + my $spec-list := nqp::split(',', $specs); + my $iter := nqp::iterator($spec-list); + while $iter { + my $spec := nqp::shift($iter); + if CompUnit::Repository::Spec.from-string($spec.trim, :$default-short-id) -> $repo-spec { + @found.push: $repo-spec; + $default-short-id = $repo-spec.short-id; + } + elsif $spec { + die "Don't know how to handle $spec"; + } + } + @found; + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit.pm rakudo-2018.03/src/core/CompUnit.pm --- rakudo-2018.02.1/src/core/CompUnit.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -class CompUnit { - has Str $.from; - has Str $.short-name; - has Version $.version; - has Str $.auth; - has Str $!WHICH; - - # The CompUnit::Repository that loaded this CompUnit. - has CompUnit::Repository $.repo is required; - - # That repository's identifier for the compilation unit. This is not globally unique. - has Str:D $.repo-id is required; - - # The low-level handle. - has CompUnit::Handle $.handle is required; - - # Whether the module was loaded from a precompilation or not. - has Bool $.precompiled = False; - - # The distribution that this compilation unit was installed as part of - # (if known). - has Distribution $.distribution; - - my $default-from = 'Perl6'; - - method new(CompUnit:U: - Str :$short-name is copy, - Version :$version, - Str :$auth, - Str :$from = $default-from, - CompUnit::Handle :$handle = CompUnit::Handle, - CompUnit::Repository :$repo, - Str :$repo-id, - Bool :$precompiled = False, - Distribution :$distribution, - ) { - self.bless( - :$short-name, - :$version, - :$auth, - :$from, - :$handle, - :$repo, - :$repo-id, - :$precompiled, - :$distribution, - ); - } - - multi method WHICH(CompUnit:D:) { $!WHICH //= self.^name } - multi method Str(CompUnit:D: --> Str:D) { $!short-name } - multi method gist(CompUnit:D: --> Str:D) { self.short-name } - - method unit() { - $.handle.unit - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CompUnit.pm6 rakudo-2018.03/src/core/CompUnit.pm6 --- rakudo-2018.02.1/src/core/CompUnit.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CompUnit.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,59 @@ +class CompUnit { + has Str $.from; + has Str $.short-name; + has Version $.version; + has Str $.auth; + has Str $!WHICH; + + # The CompUnit::Repository that loaded this CompUnit. + has CompUnit::Repository $.repo is required; + + # That repository's identifier for the compilation unit. This is not globally unique. + has Str:D $.repo-id is required; + + # The low-level handle. + has CompUnit::Handle $.handle is required; + + # Whether the module was loaded from a precompilation or not. + has Bool $.precompiled = False; + + # The distribution that this compilation unit was installed as part of + # (if known). + has Distribution $.distribution; + + my $default-from = 'Perl6'; + + method new(CompUnit:U: + Str :$short-name is copy, + Version :$version, + Str :$auth, + Str :$from = $default-from, + CompUnit::Handle :$handle = CompUnit::Handle, + CompUnit::Repository :$repo, + Str :$repo-id, + Bool :$precompiled = False, + Distribution :$distribution, + ) { + self.bless( + :$short-name, + :$version, + :$auth, + :$from, + :$handle, + :$repo, + :$repo-id, + :$precompiled, + :$distribution, + ); + } + + multi method WHICH(CompUnit:D:) { $!WHICH //= self.^name } + multi method Str(CompUnit:D: --> Str:D) { $!short-name } + multi method gist(CompUnit:D: --> Str:D) { self.short-name } + + method unit() { + $.handle.unit + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/control.pm rakudo-2018.03/src/core/control.pm --- rakudo-2018.02.1/src/core/control.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/control.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,230 +0,0 @@ -my class X::ControlFlow::Return { ... } -my class X::Eval::NoSuchLang { ... } -my class X::Multi::NoMatch { ... } -my class X::NYI { ... } -my class PseudoStash { ... } -my class Label { ... } -class CompUnit::DependencySpecification { ... } - -sub THROW(int $type, Mu \arg) { - my Mu $ex := nqp::newexception(); - nqp::setpayload($ex, arg); - nqp::setextype($ex, $type); - nqp::throw($ex); - arg; -} -sub THROW-NIL(int $type --> Nil) { - my Mu $ex := nqp::newexception(); -# nqp::setpayload($ex, Nil); - nqp::setextype($ex, $type); - nqp::throw($ex); -} - -sub RETURN-LIST(Mu \list) is raw { - my Mu $storage := nqp::getattr(list, List, '$!reified'); - nqp::iseq_i(nqp::elems($storage), 0) - ?? Nil - !! (nqp::iseq_i(nqp::elems($storage), 1) - ?? nqp::shift($storage) - !! list) -} - -proto sub return-rw(|) {*} -multi sub return-rw(--> Nil) { - nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, Nil); -} -multi sub return-rw(Mu \x --> Nil) { - nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, x); -} -multi sub return-rw(**@x is raw --> Nil) { - nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, @x); -} -proto sub return(|) {*} -multi sub return(--> Nil) { - nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, Nil); -} -multi sub return(Mu \x --> Nil) { - nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, nqp::p6recont_ro(x)); -} -multi sub return(**@x is raw --> Nil) { - nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, @x); -} - -proto sub take-rw(|) {*} -multi sub take-rw() { die "take-rw without parameters doesn't make sense" } -multi sub take-rw(\x) { THROW(nqp::const::CONTROL_TAKE, x) } -multi sub take-rw(|) { - THROW(nqp::const::CONTROL_TAKE,RETURN-LIST(nqp::p6argvmarray)) -} - -proto sub take(|) {*} -multi sub take() { die "take without parameters doesn't make sense" } -multi sub take(\x) { - THROW(nqp::const::CONTROL_TAKE, nqp::p6recont_ro(x)) -} -multi sub take(|) { - THROW( - nqp::const::CONTROL_TAKE, - nqp::p6recont_ro(RETURN-LIST(nqp::p6argvmarray)) - ) -} - -proto sub goto(|) {*} -multi sub goto(Label:D \x --> Nil) { x.goto } - -proto sub last(|) {*} -multi sub last(--> Nil) { nqp::throwextype(nqp::const::CONTROL_LAST); Nil } -multi sub last(Label:D \x --> Nil) { x.last } - -proto sub next(|) {*} -multi sub next(--> Nil) { nqp::throwextype(nqp::const::CONTROL_NEXT); Nil } -multi sub next(Label:D \x --> Nil) { x.next } - -proto sub redo(|) {*} -multi sub redo(--> Nil) { nqp::throwextype(nqp::const::CONTROL_REDO); Nil } -multi sub redo(Label:D \x --> Nil) { x.redo } - -proto sub succeed(|) {*} -multi sub succeed(--> Nil) { THROW-NIL(nqp::const::CONTROL_SUCCEED) } -multi sub succeed(\x --> Nil) { THROW(nqp::const::CONTROL_SUCCEED, x) } -multi sub succeed(| --> Nil) { - THROW(nqp::const::CONTROL_SUCCEED,RETURN-LIST(nqp::p6argvmarray)) -} - -sub proceed(--> Nil) { THROW-NIL(nqp::const::CONTROL_PROCEED) } - -sub callwith(|c) is raw { - $/ := nqp::getlexcaller('$/'); - my Mu $dispatcher := nqp::p6finddispatcher('callwith'); - $dispatcher.exhausted ?? Nil !! - $dispatcher.call_with_args(|c) -} - -sub nextwith(|c) is raw { - $/ := nqp::getlexcaller('$/'); - my Mu $dispatcher := nqp::p6finddispatcher('nextwith'); - nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, $dispatcher.exhausted - ?? Nil - !! $dispatcher.call_with_args(|c)) -} - -sub callsame() is raw { - $/ := nqp::getlexcaller('$/'); - my Mu $dispatcher := nqp::p6finddispatcher('callsame'); - $dispatcher.exhausted ?? Nil !! - $dispatcher.call_with_capture( - nqp::p6argsfordispatcher($dispatcher)) -} - -sub nextsame() is raw { - $/ := nqp::getlexcaller('$/'); - my Mu $dispatcher := nqp::p6finddispatcher('nextsame'); - nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, $dispatcher.exhausted - ?? Nil - !! $dispatcher.call_with_capture(nqp::p6argsfordispatcher($dispatcher))) -} - -sub lastcall(--> True) { - nqp::p6finddispatcher('lastcall').last(); -} - -sub nextcallee() { - my Mu $dispatcher := nqp::p6finddispatcher('nextsame'); - $dispatcher.exhausted ?? Nil !! $dispatcher.shift_callee() -} - -sub samewith(|c) { - $/ := nqp::getlexcaller('$/'); - my Mu $ctx := nqp::ctxcaller(nqp::ctx()); - until nqp::isnull($ctx) { - my $caller := nqp::getcodeobj(nqp::ctxcode($ctx)); - if nqp::istype($caller, Routine) { - if $caller.multi { - my $dispatcher := $caller.?dispatcher || die "Could not find dispatcher"; - return nqp::istype($caller, Method) - ?? $dispatcher(nqp::atkey($ctx, 'self') // $caller.package,|c) - !! $dispatcher(|c); - } - else { - return $caller(|c); - } - } - $ctx := nqp::ctxouter($ctx); - } - die "Cannot use samewith outside of a routine"; -} - -sub leave(|) { X::NYI.new(feature => 'leave').throw } - -sub emit(\value --> Nil) { - THROW(nqp::const::CONTROL_EMIT, nqp::p6recont_ro(value)); -} -sub done(--> Nil) { - THROW-NIL(nqp::const::CONTROL_DONE); -} - -proto sub die(|) {*}; -multi sub die(--> Nil) { - my $stash := CALLER::; - my $payload = $stash<$!>.DEFINITE ?? $stash<$!> !! "Died"; - $payload ~~ Exception - ?? $payload.throw - !! X::AdHoc.new(:$payload).throw -} -multi sub die(Exception:U $e --> Nil) { - X::AdHoc.new(:payload("Died with undefined " ~ $e.^name)).throw; -} -multi sub die($payload --> Nil) { - $payload ~~ Exception - ?? $payload.throw - !! X::AdHoc.new(:$payload).throw -} -multi sub die(|cap ( *@msg ) --> Nil) { - X::AdHoc.from-slurpy(|cap).throw -} - -multi sub warn(*@msg) { - my $msg = @msg.join || "Warning: something's wrong"; - my $ex := nqp::newexception(); - nqp::setmessage($ex, nqp::unbox_s($msg)); - nqp::setextype($ex, nqp::const::CONTROL_WARN); - nqp::throw($ex); - 0; -} -multi sub warn(Junction:D \j) { j.THREAD: &warn } - -constant Inf = nqp::p6box_n(nqp::inf()); -constant NaN = nqp::p6box_n(nqp::nan()); - -# For some reason, we cannot move this to Rakudo::Internals as a class -# method, because then the return value is always HLLized :-( -sub CLONE-HASH-DECONTAINERIZED(\hash) { - nqp::if( - nqp::getattr(hash,Map,'$!storage').DEFINITE, - nqp::stmts( - (my $clone := nqp::hash), - (my $iter := nqp::iterator(nqp::getattr(hash,Map,'$!storage'))), - nqp::while( - $iter, - nqp::bindkey($clone, - nqp::iterkey_s(nqp::shift($iter)), - nqp::if( - nqp::defined(nqp::iterval($iter)), - nqp::decont(nqp::iterval($iter)).Str, - '' - ) - ) - ), - $clone - ), - nqp::hash - ) -} - -sub CLONE-LIST-DECONTAINERIZED(*@list) { - my Mu $list-without := nqp::list(); - nqp::push($list-without, nqp::decont(~$_)) for @list.eager; - $list-without; -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/control.pm6 rakudo-2018.03/src/core/control.pm6 --- rakudo-2018.02.1/src/core/control.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/control.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,230 @@ +my class X::ControlFlow::Return { ... } +my class X::Eval::NoSuchLang { ... } +my class X::Multi::NoMatch { ... } +my class X::NYI { ... } +my class PseudoStash { ... } +my class Label { ... } +class CompUnit::DependencySpecification { ... } + +sub THROW(int $type, Mu \arg) { + my Mu $ex := nqp::newexception(); + nqp::setpayload($ex, arg); + nqp::setextype($ex, $type); + nqp::throw($ex); + arg; +} +sub THROW-NIL(int $type --> Nil) { + my Mu $ex := nqp::newexception(); +# nqp::setpayload($ex, Nil); + nqp::setextype($ex, $type); + nqp::throw($ex); +} + +sub RETURN-LIST(Mu \list) is raw { + my Mu $storage := nqp::getattr(list, List, '$!reified'); + nqp::isgt_i(nqp::elems($storage),1) + ?? list + !! nqp::elems($storage) + ?? nqp::shift($storage) + !! Nil +} + +proto sub return-rw(|) {*} +multi sub return-rw(--> Nil) { + nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, Nil); +} +multi sub return-rw(Mu \x --> Nil) { + nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, x); +} +multi sub return-rw(**@x is raw --> Nil) { + nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, @x); +} +proto sub return(|) {*} +multi sub return(--> Nil) { + nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, Nil); +} +multi sub return(Mu \x --> Nil) { + nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, nqp::p6recont_ro(x)); +} +multi sub return(**@x is raw --> Nil) { + nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, @x); +} + +proto sub take-rw(|) {*} +multi sub take-rw() { die "take-rw without parameters doesn't make sense" } +multi sub take-rw(\x) { THROW(nqp::const::CONTROL_TAKE, x) } +multi sub take-rw(|) { + THROW(nqp::const::CONTROL_TAKE,RETURN-LIST(nqp::p6argvmarray)) +} + +proto sub take(|) {*} +multi sub take() { die "take without parameters doesn't make sense" } +multi sub take(\x) { + THROW(nqp::const::CONTROL_TAKE, nqp::p6recont_ro(x)) +} +multi sub take(|) { + THROW( + nqp::const::CONTROL_TAKE, + nqp::p6recont_ro(RETURN-LIST(nqp::p6argvmarray)) + ) +} + +proto sub goto(|) {*} +multi sub goto(Label:D \x --> Nil) { x.goto } + +proto sub last(|) {*} +multi sub last(--> Nil) { nqp::throwextype(nqp::const::CONTROL_LAST); Nil } +multi sub last(Label:D \x --> Nil) { x.last } + +proto sub next(|) {*} +multi sub next(--> Nil) { nqp::throwextype(nqp::const::CONTROL_NEXT); Nil } +multi sub next(Label:D \x --> Nil) { x.next } + +proto sub redo(|) {*} +multi sub redo(--> Nil) { nqp::throwextype(nqp::const::CONTROL_REDO); Nil } +multi sub redo(Label:D \x --> Nil) { x.redo } + +proto sub succeed(|) {*} +multi sub succeed(--> Nil) { THROW-NIL(nqp::const::CONTROL_SUCCEED) } +multi sub succeed(\x --> Nil) { THROW(nqp::const::CONTROL_SUCCEED, x) } +multi sub succeed(| --> Nil) { + THROW(nqp::const::CONTROL_SUCCEED,RETURN-LIST(nqp::p6argvmarray)) +} + +sub proceed(--> Nil) { THROW-NIL(nqp::const::CONTROL_PROCEED) } + +sub callwith(|c) is raw { + $/ := nqp::getlexcaller('$/'); + my Mu $dispatcher := nqp::p6finddispatcher('callwith'); + $dispatcher.exhausted ?? Nil !! + $dispatcher.call_with_args(|c) +} + +sub nextwith(|c) is raw { + $/ := nqp::getlexcaller('$/'); + my Mu $dispatcher := nqp::p6finddispatcher('nextwith'); + nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, $dispatcher.exhausted + ?? Nil + !! $dispatcher.call_with_args(|c)) +} + +sub callsame() is raw { + $/ := nqp::getlexcaller('$/'); + my Mu $dispatcher := nqp::p6finddispatcher('callsame'); + $dispatcher.exhausted ?? Nil !! + $dispatcher.call_with_capture( + nqp::p6argsfordispatcher($dispatcher)) +} + +sub nextsame() is raw { + $/ := nqp::getlexcaller('$/'); + my Mu $dispatcher := nqp::p6finddispatcher('nextsame'); + nqp::throwpayloadlexcaller(nqp::const::CONTROL_RETURN, $dispatcher.exhausted + ?? Nil + !! $dispatcher.call_with_capture(nqp::p6argsfordispatcher($dispatcher))) +} + +sub lastcall(--> True) { + nqp::p6finddispatcher('lastcall').last(); +} + +sub nextcallee() { + my Mu $dispatcher := nqp::p6finddispatcher('nextsame'); + $dispatcher.exhausted ?? Nil !! $dispatcher.shift_callee() +} + +sub samewith(|c) { + $/ := nqp::getlexcaller('$/'); + my Mu $ctx := nqp::ctxcaller(nqp::ctx()); + until nqp::isnull($ctx) { + my $caller := nqp::getcodeobj(nqp::ctxcode($ctx)); + if nqp::istype($caller, Routine) { + if $caller.multi { + my $dispatcher := $caller.?dispatcher || die "Could not find dispatcher"; + return nqp::istype($caller, Method) + ?? $dispatcher(nqp::atkey($ctx, 'self') // $caller.package,|c) + !! $dispatcher(|c); + } + else { + return $caller(|c); + } + } + $ctx := nqp::ctxouter($ctx); + } + die "Cannot use samewith outside of a routine"; +} + +sub leave(|) { X::NYI.new(feature => 'leave').throw } + +sub emit(\value --> Nil) { + THROW(nqp::const::CONTROL_EMIT, nqp::p6recont_ro(value)); +} +sub done(--> Nil) { + THROW-NIL(nqp::const::CONTROL_DONE); +} + +proto sub die(|) {*}; +multi sub die(--> Nil) { + my $stash := CALLER::; + my $payload = $stash<$!>.DEFINITE ?? $stash<$!> !! "Died"; + $payload ~~ Exception + ?? $payload.throw + !! X::AdHoc.new(:$payload).throw +} +multi sub die(Exception:U $e --> Nil) { + X::AdHoc.new(:payload("Died with undefined " ~ $e.^name)).throw; +} +multi sub die($payload --> Nil) { + $payload ~~ Exception + ?? $payload.throw + !! X::AdHoc.new(:$payload).throw +} +multi sub die(|cap ( *@msg ) --> Nil) { + X::AdHoc.from-slurpy(|cap).throw +} + +multi sub warn(*@msg) { + my $msg = @msg.join || "Warning: something's wrong"; + my $ex := nqp::newexception(); + nqp::setmessage($ex, nqp::unbox_s($msg)); + nqp::setextype($ex, nqp::const::CONTROL_WARN); + nqp::throw($ex); + 0; +} +multi sub warn(Junction:D \j) { j.THREAD: &warn } + +constant Inf = nqp::p6box_n(nqp::inf()); +constant NaN = nqp::p6box_n(nqp::nan()); + +# For some reason, we cannot move this to Rakudo::Internals as a class +# method, because then the return value is always HLLized :-( +sub CLONE-HASH-DECONTAINERIZED(\hash) { + nqp::if( + nqp::getattr(hash,Map,'$!storage').DEFINITE, + nqp::stmts( + (my $clone := nqp::hash), + (my $iter := nqp::iterator(nqp::getattr(hash,Map,'$!storage'))), + nqp::while( + $iter, + nqp::bindkey($clone, + nqp::iterkey_s(nqp::shift($iter)), + nqp::if( + nqp::defined(nqp::iterval($iter)), + nqp::decont(nqp::iterval($iter)).Str, + '' + ) + ) + ), + $clone + ), + nqp::hash + ) +} + +sub CLONE-LIST-DECONTAINERIZED(*@list) { + my Mu $list-without := nqp::list(); + nqp::push($list-without, nqp::decont(~$_)) for @list.eager; + $list-without; +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Cool.pm rakudo-2018.03/src/core/Cool.pm --- rakudo-2018.02.1/src/core/Cool.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Cool.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,522 +0,0 @@ -my class Cool { # declared in BOOTSTRAP - # class Cool is Any - - ## numeric methods - - method abs() { self.Numeric.abs } - method conj() { self.Numeric.conj } - method sqrt() { self.Numeric.sqrt } - method sign() { self.Real.sign } - method rand() { self.Num.rand } - method sin() { self.Numeric.sin } - method asin() { self.Numeric.asin } - method cos() { self.Numeric.cos } - method acos() { self.Numeric.acos } - method tan() { self.Numeric.tan } - method atan() { self.Numeric.atan } - method atan2($y = 1e0) { self.Numeric.atan2($y.Numeric) } - method sec() { self.Numeric.sec } - method asec() { self.Numeric.asec } - method cosec() { self.Numeric.cosec } - method acosec() { self.Numeric.acosec } - method cotan() { self.Numeric.cotan } - method acotan() { self.Numeric.acotan } - method sinh() { self.Numeric.sinh } - method asinh() { self.Numeric.asinh } - method cosh() { self.Numeric.cosh } - method acosh() { self.Numeric.acosh } - method tanh() { self.Numeric.tanh } - method atanh() { self.Numeric.atanh } - method sech() { self.Numeric.sech } - method asech() { self.Numeric.asech } - method cosech() { self.Numeric.cosech } - method acosech() { self.Numeric.acosech } - method cotanh() { self.Numeric.cotanh } - method acotanh() { self.Numeric.acotanh } - method cis() { self.Numeric.cis } - method is-prime(--> Bool:D) { self.Real.is-prime } - - proto method log(|) {*} - multi method log(Cool:D: ) { self.Numeric.log } - multi method log(Cool:D: $base) { self.Numeric.log($base.Numeric) } - - proto method exp(|) {*} - multi method exp(Cool:D: ) { self.Numeric.exp } - multi method exp(Cool:D: $base) { self.Numeric.exp($base.Numeric) } - - proto method round(|) {*} - multi method round() { self.Numeric.round() } - multi method round($base) { self.Numeric.round($base) } - - method roots(Cool $n) { self.Numeric.roots($n) } - method log10() { self.Numeric.log10 } - method unpolar($n) { self.Numeric.unpolar($n.Numeric) } - - method floor() { self.Numeric.floor } - method ceiling() { self.Numeric.ceiling } - method truncate() { self.Numeric.truncate } - - ## string methods - - method chars(--> Int:D) { - self.Str.chars - } - method codes() { - self.Str.codes - } - - method fmt($format = '%s') { - Rakudo::Internals.initialize-sprintf-handler; - nqp::p6box_s( - nqp::sprintf(nqp::unbox_s($format.Stringy), nqp::list(self)) - ) - } - - method substr($from, $length?) { substr( self,$from,$length) } - method substr-rw(\SELF: $from, $length?) { substr-rw(SELF,$from,$length) } - - method uc() { - self.Str.uc - } - - method lc() { - self.Str.lc - } - - method tc() { - self.Str.tc - } - - method fc() { - self.Str.fc - } - - method tclc() { - self.Str.tclc - } - - method wordcase() { self.Str.wordcase } - - method uniname() { uniname(self) } - method uninames() { uninames(self) } - method unival() { unival(self) } - method univals() { univals(self) } - method uniprop(|c) { uniprop(self, |c) } - method uniprop-int(|c) { uniprop-int(self, |c) } - method uniprop-bool(|c) { uniprop-bool(self, |c) } - method uniprop-str(|c) { uniprop-str(self, |c) } - method uniprops(|c) { uniprops(self, |c) } - method unimatch(|c) { unimatch(self, |c) } - - method chomp(Cool:D:) { self.Str.chomp } - - proto method chop(|) {*} - multi method chop(Cool:D:) { self.Str.chop } - multi method chop(Cool:D: Int() $n) { self.Str.chop($n) } - - method ord(--> Int:D) { - self.Str.ord - } - method chr() { - self.Int.chr; - } - method chrs(Cool:D:) { chrs(self.list) } - method ords(Cool:D:) { self.Str.ords } - - - method flip() { - self.Str.flip - } - method trans(|c) { self.Str.trans(|c) } - - method starts-with(Cool:D: |c) { - self.Str.starts-with(|c) - } - - method ends-with(Cool:D: |c) { - self.Str.ends-with(|c) - } - - method substr-eq(Cool:D: |c) { - self.Str.substr-eq(|c) - } - - method contains(Cool:D: |c) { - self.Str.contains(|c) - } - - method indices(Cool:D: |c) { - self.Str.indices(|c) - } - - method index(Cool:D: |c) { - self.Str.index(|c) - } - - method rindex(Cool:D: |c) { - self.Str.rindex(|c) - } - - method split(Cool: |c) { - self.Stringy.split(|c); - } - - method match(Cool:D: |c) { - $/ := nqp::getlexcaller('$/'); - self.Stringy.match(|c) - } - - method comb(|c) { self.Str.comb(|c) } - method lines(Cool:D: |c) { self.Str.lines(|c) } - method words(Cool:D: |c) { self.Str.words(|c) } - - method subst(|c) { - $/ := nqp::getlexcaller('$/'); - self.Stringy.subst(|c); - } - - # `$value-to-subst-mutate` will show up in errors when called on non-rw - # container, so use more descriptive name instead of just `$self` - method subst-mutate(Cool:D $value-to-subst-mutate is rw: |c) { - $/ := nqp::getlexcaller('$/'); - my $str = $value-to-subst-mutate.Str; - my $match := $str.subst-mutate(|c); - $value-to-subst-mutate = $str if $match; # only change if successful - $match - } - - proto method IO(|) {*} - multi method IO(Cool:D:) { IO::Path.new(self) } - multi method IO(Cool:U:) { IO::Path } - - method sprintf(*@args) { sprintf(self, @args) }; - method printf (*@args) { printf(self, @args) }; - method samecase(Cool:D: Cool $pattern) { self.Stringy.samecase($pattern) } - - method path() { self.Stringy.IO } - method trim () { self.Stringy.trim }; - method trim-leading () { self.Stringy.trim-leading }; - method trim-trailing() { self.Stringy.trim-trailing }; - - method EVAL(*%opts) { - EVAL(self, context => CALLER::, |%opts); - } - - multi method Real() { - nqp::if( - nqp::istype((my $numeric := self.Numeric), Failure), - $numeric, - $numeric.Real - ) - } - - proto method Int(|) {*} - multi method Int() { - nqp::if( - nqp::istype((my $numeric := self.Numeric), Failure), - $numeric, - $numeric.Int - ) - } - - proto method UInt(|) {*} - multi method UInt() { - my $got := self.Int; - $got < 0 - ?? Failure.new(X::OutOfRange.new( - :what('Coercion to UInt'), - :$got, - :range<0..^Inf>)) - !! $got - } - - method Num() { - nqp::if( - nqp::istype((my $numeric := self.Numeric), Failure), - $numeric, - $numeric.Num - ) - } - - method Rat() { - nqp::if( - nqp::istype((my $numeric := self.Numeric), Failure), - $numeric, - $numeric.Rat - ) - } - - method FatRat() { - nqp::if( - nqp::istype((my $numeric := self.Numeric), Failure), - $numeric, - $numeric.FatRat - ) - } - - method Complex() { - nqp::if( - nqp::istype((my $numeric := self.Numeric), Failure), - $numeric, - $numeric.Complex - ) - } -} -Metamodel::ClassHOW.exclude_parent(Cool); - -proto sub chop(|) {*} -multi sub chop(Cool:D $s --> Str:D) { $s.chop } -multi sub chop(Cool:D $s, Int() $n --> Str:D) { $s.chop($n) } - -sub chomp(Cool:D $s --> Str:D) { $s.chomp } - -sub flip(Cool $s --> Str:D) { $s.flip } -sub index(Cool $s,$needle,$pos=0) { $s.index($needle,$pos) } -sub lc(Cool $s) { $s.lc } -sub ord(Cool $s) { $s.ord } -sub uc(Cool $s) { $s.uc } -sub tc(Cool $s) { $s.tc } -sub fc(Cool $s) { $s.fc } -sub tclc(Cool $s) { $s.tclc } - -sub indices(Cool $s, |c) { - $s.indices(|c); -} - -proto sub rindex($, $, $?) is pure {*}; -multi sub rindex(Cool $s, Cool $needle, Cool $pos) { $s.rindex($needle, $pos) }; -multi sub rindex(Cool $s, Cool $needle) { $s.rindex($needle) }; - -proto sub ords($) is pure {*} -multi sub ords(Cool $s) { ords($s.Stringy) } - -proto sub comb($, $, $?) {*} -multi sub comb(Regex $matcher, Cool $input, $limit = *) { $input.comb($matcher, $limit) } -multi sub comb(Str $matcher, Cool $input, $limit = *) { $input.comb($matcher, $limit) } -multi sub comb(Int:D $matcher, Cool $input, $limit = *) { $input.comb($matcher, $limit) } - -proto sub wordcase($) is pure {*} -multi sub wordcase(Str:D $x) {$x.wordcase } -multi sub wordcase(Cool $x) {$x.Str.wordcase } - -sub sprintf(Cool $format, *@args) { - CATCH { - when X::Cannot::Lazy { - X::Cannot::Lazy.new(:action('(s)printf')).throw - } - default { - Rakudo::Internals.HANDLE-NQP-SPRINTF-ERRORS($_).throw - } - } - Rakudo::Internals.initialize-sprintf-handler; - @args.elems; - nqp::p6box_s( - nqp::sprintf(nqp::unbox_s($format.Stringy), - nqp::clone(nqp::getattr(@args||[], List, '$!reified')) - ) - ) -} - -sub printf(Cool $format, *@args) { print sprintf $format, @args } -sub samecase(Cool $string, Cool $pattern) { $string.samecase($pattern) } -sub split($pat, Cool $target, |c) { $target.split($pat, |c) } - -proto sub chars($) is pure {*} -multi sub chars(Cool $x) { $x.Str.chars } -multi sub chars(Str:D $x) { nqp::p6box_i(nqp::chars($x)) } -multi sub chars(str $x --> int) { nqp::chars($x) } - -# These probably belong in a separate unicodey file - -proto sub uniname(|) {*} -multi sub uniname(Str:D $str) { $str ?? uniname($str.ord) !! Nil } -multi sub uniname(Int:D $code) { nqp::getuniname($code) } - -proto sub uninames(|) {*} -multi sub uninames(Str:D $str) { $str.NFC.map: { uniname($_) } } - -#?if jvm -multi sub unival(|) { die 'unival NYI on jvm backend' } -multi sub univals(|) { die 'univals NYI on jvm backend' } -multi sub uniprop(|) { die 'uniprop NYI on jvm backend' } -multi sub uniprop-int(|) { die 'uniprop-int NYI on jvm backend' } -multi sub uniprop-bool(|) { die 'uniprop-bool NYI on jvm backend' } -multi sub uniprop-str(|) { die 'uniprop-str NYI on jvm backend' } -multi sub uniprops(|) { die 'uniprops NYI on jvm backend' } -multi sub unimatch(|) { die 'unimatch NYI on jvm backend' } -#?endif - -#?if moar -proto sub uniprop(|) {*} -multi sub uniprop(Str:D $str, |c) { $str ?? uniprop($str.ord, |c) !! Nil } -multi sub uniprop(Int:D $code) { - nqp::getuniprop_str($code,nqp::unipropcode('General_Category')); -} -multi sub uniprop(Int:D $code, Stringy:D $propname) { - # prop-mappings can be removed when MoarVM bug #448 is fixed... - ## The code below was generated by tools/build/makeUNIPROP.pl6 - my constant $prop-mappings = nqp::hash( - 'OGr_Ext','Other_Grapheme_Extend','tc','Titlecase_Mapping', - 'cjkIRG_MSource','kIRG_MSource','Dash','Dash','Pat_Syn','Pattern_Syntax', - 'IDST','IDS_Trinary_Operator','IDC','ID_Continue','Dia','Diacritic', - 'Cased','Cased','hst','Hangul_Syllable_Type','QMark','Quotation_Mark', - 'Radical','Radical','NFD_QC','NFD_Quick_Check','jt','Joining_Type', - 'cf','Case_Folding','cjkIRG_TSource','kIRG_TSource','sc','Script', - 'SD','Soft_Dotted','CWCM','Changes_When_Casemapped', - 'cjkOtherNumeric','kOtherNumeric','scf','Simple_Case_Folding', - 'sfc','Simple_Case_Folding','isc','ISO_Comment','na1','Unicode_1_Name', - 'Lower','Lowercase','Join_C','Join_Control','JSN','Jamo_Short_Name', - 'bc','Bidi_Class','jg','Joining_Group','dm','Decomposition_Mapping', - 'lc','Lowercase_Mapping','cjkIRG_USource','kIRG_USource', - 'NFKC_CF','NFKC_Casefold','slc','Simple_Lowercase_Mapping', - 'InSC','Indic_Syllabic_Category','XO_NFC','Expands_On_NFC', - 'XO_NFD','Expands_On_NFD','cjkAccountingNumeric','kAccountingNumeric', - 'Upper','Uppercase','WSpace','White_Space','space','White_Space', - 'cjkIRG_VSource','kIRG_VSource','STerm','Sentence_Terminal', - 'NFKD_QC','NFKD_Quick_Check','CWT','Changes_When_Titlecased','Math','Math', - 'uc','Uppercase_Mapping','NFKC_QC','NFKC_Quick_Check','SB','Sentence_Break', - 'stc','Simple_Titlecase_Mapping','Alpha','Alphabetic', - 'CE','Composition_Exclusion','NChar','Noncharacter_Code_Point', - 'OAlpha','Other_Alphabetic','XIDC','XID_Continue','age','Age', - 'cjkPrimaryNumeric','kPrimaryNumeric','OIDS','Other_ID_Start', - 'UIdeo','Unified_Ideograph','FC_NFKC','FC_NFKC_Closure','CI','Case_Ignorable', - 'Hyphen','Hyphen','nv','Numeric_Value','CWKCF','Changes_When_NFKC_Casefolded', - 'XO_NFKD','Expands_On_NFKD','InPC','Indic_Positional_Category', - 'dt','Decomposition_Type','cjkIICore','kIICore','Bidi_M','Bidi_Mirrored', - 'CWU','Changes_When_Uppercased','IDS','ID_Start','Gr_Ext','Grapheme_Extend', - 'XIDS','XID_Start','XO_NFKC','Expands_On_NFKC','OUpper','Other_Uppercase', - 'OMath','Other_Math','Gr_Link','Grapheme_Link','Bidi_C','Bidi_Control', - 'DI','Default_Ignorable_Code_Point','CWCF','Changes_When_Casefolded', - 'cjkIRG_GSource','kIRG_GSource','WB','Word_Break','NFC_QC','NFC_Quick_Check', - 'cjkIRG_JSource','kIRG_JSource','ODI','Other_Default_Ignorable_Code_Point', - 'LOE','Logical_Order_Exception','bpb','Bidi_Paired_Bracket', - 'PCM','Prepended_Concatenation_Mark','OLower','Other_Lowercase', - 'OIDC','Other_ID_Continue','VS','Variation_Selector','Ext','Extender', - 'Comp_Ex','Full_Composition_Exclusion','IDSB','IDS_Binary_Operator', - 'nt','Numeric_Type','cjkCompatibilityVariant','kCompatibilityVariant', - 'suc','Simple_Uppercase_Mapping','Term','Terminal_Punctuation', - 'lb','Line_Break','cjkIRG_HSource','kIRG_HSource','ea','East_Asian_Width', - 'AHex','ASCII_Hex_Digit','cjkIRG_KSource','kIRG_KSource', - 'Pat_WS','Pattern_White_Space','Hex','Hex_Digit', - 'cjkIRG_KPSource','kIRG_KPSource','bpt','Bidi_Paired_Bracket_Type', - 'gc','General_Category','GCB','Grapheme_Cluster_Break', - 'Gr_Base','Grapheme_Base','na','Name','scx','Script_Extensions', - 'Ideo','Ideographic','Name_Alias','Name_Alias','blk','Block','Dep','Deprecated', - 'CWL','Changes_When_Lowercased','bmg','Bidi_Mirroring_Glyph', - 'cjkRSUnicode','kRSUnicode','Unicode_Radical_Stroke','kRSUnicode', - 'URS','kRSUnicode','ccc','Canonical_Combining_Class', - ); - my constant $prefs = nqp::hash( - 'Other_Grapheme_Extend','B','Titlecase_Mapping','tc','Dash','B', - 'Emoji_Modifier_Base','B','Emoji_Modifier','B','Pattern_Syntax','B', - 'IDS_Trinary_Operator','B','ID_Continue','B','Diacritic','B','Cased','B', - 'Hangul_Syllable_Type','S','Quotation_Mark','B','Radical','B', - 'NFD_Quick_Check','S','Joining_Type','S','Case_Folding','S','Script','S', - 'Soft_Dotted','B','Changes_When_Casemapped','B','Simple_Case_Folding','S', - 'ISO_Comment','S','Lowercase','B','Join_Control','B','Bidi_Class','S', - 'Joining_Group','S','Decomposition_Mapping','S','Lowercase_Mapping','lc', - 'NFKC_Casefold','S','Simple_Lowercase_Mapping','S', - 'Indic_Syllabic_Category','S','Expands_On_NFC','B','Expands_On_NFD','B', - 'Uppercase','B','White_Space','B','Sentence_Terminal','B', - 'NFKD_Quick_Check','S','Changes_When_Titlecased','B','Math','B', - 'Uppercase_Mapping','uc','NFKC_Quick_Check','S','Sentence_Break','S', - 'Simple_Titlecase_Mapping','S','Alphabetic','B','Composition_Exclusion','B', - 'Noncharacter_Code_Point','B','Other_Alphabetic','B','XID_Continue','B', - 'Age','S','Other_ID_Start','B','Unified_Ideograph','B','FC_NFKC_Closure','S', - 'Case_Ignorable','B','Hyphen','B','Numeric_Value','nv', - 'Changes_When_NFKC_Casefolded','B','Expands_On_NFKD','B', - 'Indic_Positional_Category','S','Decomposition_Type','S','Bidi_Mirrored','B', - 'Changes_When_Uppercased','B','ID_Start','B','Grapheme_Extend','B', - 'XID_Start','B','Expands_On_NFKC','B','Other_Uppercase','B','Other_Math','B', - 'Grapheme_Link','B','Bidi_Control','B','Default_Ignorable_Code_Point','B', - 'Changes_When_Casefolded','B','Word_Break','S','NFC_Quick_Check','S', - 'Other_Default_Ignorable_Code_Point','B','Logical_Order_Exception','B', - 'Prepended_Concatenation_Mark','B','Other_Lowercase','B', - 'Other_ID_Continue','B','Variation_Selector','B','Extender','B', - 'Full_Composition_Exclusion','B','IDS_Binary_Operator','B','Numeric_Type','S', - 'kCompatibilityVariant','S','Simple_Uppercase_Mapping','S', - 'Terminal_Punctuation','B','Line_Break','S','East_Asian_Width','S', - 'ASCII_Hex_Digit','B','Pattern_White_Space','B','Hex_Digit','B', - 'Bidi_Paired_Bracket_Type','S','General_Category','S', - 'Grapheme_Cluster_Break','S','Grapheme_Base','B','Name','na','Ideographic','B', - 'Block','S','Emoji_Presentation','B','Emoji','B','Deprecated','B', - 'Changes_When_Lowercased','B','Bidi_Mirroring_Glyph','bmg', - 'Canonical_Combining_Class','S', - ); - ## End generated code - $propname := nqp::atkey($prop-mappings, $propname) if nqp::existskey($prop-mappings,$propname); - my $prop := nqp::unipropcode($propname); - given nqp::atkey($prefs, $propname) { - when 'S' { nqp::getuniprop_str($code,$prop) } - when 'I' { nqp::getuniprop_int($code,$prop) } - when 'B' { nqp::p6bool(nqp::getuniprop_bool($code,$prop)) } - when 'lc' { nqp::lc( nqp::chr( nqp::unbox_i($code) ) ) } - when 'tc' { nqp::tc( nqp::chr( nqp::unbox_i($code) ) ) } - when 'uc' { nqp::uc( nqp::chr( nqp::unbox_i($code) ) ) } - when 'na' { nqp::getuniname($code) } - when 'nv' { unival($code) } - when 'bmg' { - my int $bmg-ord = nqp::getuniprop_int($code, $prop); - $bmg-ord ?? nqp::chr($bmg-ord) !! ''; - } - default { - my $result = nqp::getuniprop_str($code,$prop); - if $result ne '' { nqp::bindkey($prefs, $propname, 'S'); $result } - else { nqp::bindkey($prefs, $propname, 'I'); nqp::getuniprop_int($code,$prop) } - } - } -} -# Unicode functions -proto sub uniprop-int(|) {*} -multi sub uniprop-int(Str:D $str, Stringy:D $propname) { - $str ?? uniprop-int($str.ord, $propname) !! Nil } -multi sub uniprop-int(Int:D $code, Stringy:D $propname) { - nqp::getuniprop_int($code,nqp::unipropcode($propname)); -} - -proto sub uniprop-bool(|) {*} -multi sub uniprop-bool(Str:D $str, Stringy:D $propname) { - $str ?? uniprop-bool($str.ord, $propname) !! Nil -} -multi sub uniprop-bool(Int:D $code, Stringy:D $propname) { - nqp::p6bool(nqp::getuniprop_bool($code,nqp::unipropcode($propname))); -} - -proto sub uniprop-str(|) {*} -multi sub uniprop-str(Str:D $str, Stringy:D $propname) { - $str ?? uniprop-str($str.ord, $propname) !! Nil -} -multi sub uniprop-str(Int:D $code, Stringy:D $propname) { - nqp::getuniprop_str($code,nqp::unipropcode($propname)); -} -proto sub uniprops(|) {*} -multi sub uniprops(Str:D $str, Stringy:D $propname = "General_Category") { - $str.ords.map: { uniprop($_, $propname) } -} - -proto sub unival(|) {*} -multi sub unival(Str:D $str) { $str ?? unival($str.ord) !! Nil } -multi sub unival(Int:D $code) { - state $nuprop = nqp::unipropcode("Numeric_Value_Numerator"); - state $deprop = nqp::unipropcode("Numeric_Value_Denominator"); - my $nu = nqp::getuniprop_str($code, $nuprop); - my $de = nqp::getuniprop_str($code, $deprop); - !$de || $de eq '1' ?? $nu.Int !! $nu / $de; -} - -proto sub univals(|) {*} -multi sub univals(Str:D $str) { $str.ords.map: { unival($_) } } - -proto sub unimatch(|) {*} -multi sub unimatch(Str:D $str, |c) { $str ?? unimatch($str.ord, |c) !! Nil } -# This multi below can be removed when MoarVM bug #448 is fixed -multi sub unimatch(Int:D $code, Stringy:D $pvalname, Stringy:D $propname) { - uniprop($code, $propname) eq $pvalname; -} -multi sub unimatch(Int:D $code, Stringy:D $pvalname, Stringy:D $propname = $pvalname) { - my $prop := nqp::unipropcode($propname); - nqp::p6bool(nqp::matchuniprop($code,$prop,nqp::unipvalcode($prop,$pvalname))); -} -#?endif - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Cool.pm6 rakudo-2018.03/src/core/Cool.pm6 --- rakudo-2018.02.1/src/core/Cool.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Cool.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,594 @@ +BEGIN { + # Workaround for regression in https://github.com/rakudo/rakudo/issues/1566 + # The actual bug is that Callable role gets mixed in into routines + # before it's composed, and when it is composed, the routines end up + # not "doing" `Callable` role, even though they do. There are many more + # routines suffering this issue, but these three regressed since last + # release and we don't have the time to fix the primary bug before the + # release, so in this fudge goes. + &min.^compose; + &max.^compose; + &minmax.^compose; +} + +my class Cool { # declared in BOOTSTRAP + # class Cool is Any + + ## numeric methods + + method abs() { self.Numeric.abs } + method conj() { self.Numeric.conj } + method sqrt() { self.Numeric.sqrt } + method sign() { self.Real.sign } + method rand() { self.Num.rand } + method sin() { self.Numeric.sin } + method asin() { self.Numeric.asin } + method cos() { self.Numeric.cos } + method acos() { self.Numeric.acos } + method tan() { self.Numeric.tan } + method atan() { self.Numeric.atan } + method atan2($y = 1e0) { self.Numeric.atan2($y.Numeric) } + method sec() { self.Numeric.sec } + method asec() { self.Numeric.asec } + method cosec() { self.Numeric.cosec } + method acosec() { self.Numeric.acosec } + method cotan() { self.Numeric.cotan } + method acotan() { self.Numeric.acotan } + method sinh() { self.Numeric.sinh } + method asinh() { self.Numeric.asinh } + method cosh() { self.Numeric.cosh } + method acosh() { self.Numeric.acosh } + method tanh() { self.Numeric.tanh } + method atanh() { self.Numeric.atanh } + method sech() { self.Numeric.sech } + method asech() { self.Numeric.asech } + method cosech() { self.Numeric.cosech } + method acosech() { self.Numeric.acosech } + method cotanh() { self.Numeric.cotanh } + method acotanh() { self.Numeric.acotanh } + method cis() { self.Numeric.cis } + method is-prime(--> Bool:D) { self.Real.is-prime } + + proto method log(|) {*} + multi method log(Cool:D: ) { self.Numeric.log } + multi method log(Cool:D: $base) { self.Numeric.log($base.Numeric) } + + proto method exp(|) {*} + multi method exp(Cool:D: ) { self.Numeric.exp } + multi method exp(Cool:D: $base) { self.Numeric.exp($base.Numeric) } + + proto method round(|) {*} + multi method round() { self.Numeric.round() } + multi method round($base) { self.Numeric.round($base) } + + method roots(Cool $n) { self.Numeric.roots($n) } + method log10() { self.Numeric.log10 } + method unpolar($n) { self.Numeric.unpolar($n.Numeric) } + + method floor() { self.Numeric.floor } + method ceiling() { self.Numeric.ceiling } + method truncate() { self.Numeric.truncate } + + ## string methods + + method chars(--> Int:D) { + self.Str.chars + } + method codes() { + self.Str.codes + } + + method fmt($format = '%s') { + Rakudo::Internals.initialize-sprintf-handler; + nqp::p6box_s( + nqp::sprintf(nqp::unbox_s($format.Stringy), nqp::list(self)) + ) + } + + method uc() { + self.Str.uc + } + + method lc() { + self.Str.lc + } + + method tc() { + self.Str.tc + } + + method fc() { + self.Str.fc + } + + method tclc() { + self.Str.tclc + } + + method wordcase() { self.Str.wordcase } + + method uniname() { uniname(self) } + method uninames() { uninames(self) } + method unival() { unival(self) } + method univals() { univals(self) } + method uniprop(|c) { uniprop(self, |c) } + method uniprop-int(|c) { uniprop-int(self, |c) } + method uniprop-bool(|c) { uniprop-bool(self, |c) } + method uniprop-str(|c) { uniprop-str(self, |c) } + method uniprops(|c) { uniprops(self, |c) } + method unimatch(|c) { unimatch(self, |c) } + + method chomp(Cool:D:) { self.Str.chomp } + + proto method chop(|) {*} + multi method chop(Cool:D:) { self.Str.chop } + multi method chop(Cool:D: Int() $n) { self.Str.chop($n) } + + method ord(--> Int:D) { + self.Str.ord + } + method chr() { + self.Int.chr; + } + + proto method chrs(|) {*} + multi method chrs(Cool:D:) { self.list.chrs } + + proto method ords(|) {*} + multi method ords(Cool:D:) { self.Str.ords } + + method flip() { + self.Str.flip + } + method trans(|c) { self.Str.trans(|c) } + + method starts-with(Cool:D: |c) { + self.Str.starts-with(|c) + } + + method ends-with(Cool:D: |c) { + self.Str.ends-with(|c) + } + + proto method substr(|) {*} + multi method substr() { self.Str.substr } + multi method substr(\from) { self.Str.substr(from) } + multi method substr(\from, \chars) { self.Str.substr(from,chars) } + + proto method substr-rw(|) {*} + multi method substr-rw(\SELF:) is rw { + (SELF = self.Str).substr-rw + } + multi method substr-rw(\SELF: \from) is rw { + (SELF = self.Str).substr-rw(from) + } + multi method substr-rw(\SELF: \from, \chars) is rw { + (SELF = self.Str).substr-rw(from,chars) + } + + method substr-eq(Cool:D: |c) { + self.Str.substr-eq(|c) + } + + method contains(Cool:D: |c) { + self.Str.contains(|c) + } + + method indices(Cool:D: |c) { + self.Str.indices(|c) + } + + method index(Cool:D: |c) { + self.Str.index(|c) + } + + method rindex(Cool:D: |c) { + self.Str.rindex(|c) + } + + method split(Cool: |c) { + self.Stringy.split(|c); + } + + method match(Cool:D: |c) { + $/ := nqp::getlexcaller('$/'); + self.Stringy.match(|c) + } + + method comb(|c) { self.Str.comb(|c) } + method lines(Cool:D: |c) { self.Str.lines(|c) } + method words(Cool:D: |c) { self.Str.words(|c) } + + method subst(|c) { + $/ := nqp::getlexcaller('$/'); + self.Stringy.subst(|c); + } + + # `$value-to-subst-mutate` will show up in errors when called on non-rw + # container, so use more descriptive name instead of just `$self` + method subst-mutate(Cool:D $value-to-subst-mutate is rw: |c) { + $/ := nqp::getlexcaller('$/'); + my $str = $value-to-subst-mutate.Str; + my $match := $str.subst-mutate(|c); + $value-to-subst-mutate = $str if $match; # only change if successful + $match + } + + proto method IO(|) {*} + multi method IO(Cool:D:) { IO::Path.new(self) } + multi method IO(Cool:U:) { IO::Path } + + method sprintf(*@args) { sprintf(self, @args) }; + method printf (*@args) { printf(self, @args) }; + method samecase(Cool:D: Cool $pattern) { self.Stringy.samecase($pattern) } + + method path() { self.Stringy.IO } + method trim () { self.Stringy.trim }; + method trim-leading () { self.Stringy.trim-leading }; + method trim-trailing() { self.Stringy.trim-trailing }; + + method EVAL(*%opts) { + EVAL(self, context => CALLER::, |%opts); + } + + multi method Real() { + nqp::if( + nqp::istype((my $numeric := self.Numeric), Failure), + $numeric, + $numeric.Real + ) + } + + proto method Int(|) {*} + multi method Int() { + nqp::if( + nqp::istype((my $numeric := self.Numeric), Failure), + $numeric, + $numeric.Int + ) + } + + proto method UInt(|) {*} + multi method UInt() { + my $got := self.Int; + $got < 0 + ?? Failure.new(X::OutOfRange.new( + :what('Coercion to UInt'), + :$got, + :range<0..^Inf>)) + !! $got + } + + method Num() { + nqp::if( + nqp::istype((my $numeric := self.Numeric), Failure), + $numeric, + $numeric.Num + ) + } + + method Rat() { + nqp::if( + nqp::istype((my $numeric := self.Numeric), Failure), + $numeric, + $numeric.Rat + ) + } + + method FatRat() { + nqp::if( + nqp::istype((my $numeric := self.Numeric), Failure), + $numeric, + $numeric.FatRat + ) + } + + method Complex() { + nqp::if( + nqp::istype((my $numeric := self.Numeric), Failure), + $numeric, + $numeric.Complex + ) + } +} +Metamodel::ClassHOW.exclude_parent(Cool); + +proto sub chop(|) {*} +multi sub chop(Cool:D $s --> Str:D) { $s.chop } +multi sub chop(Cool:D $s, Int() $n --> Str:D) { $s.chop($n) } + +proto sub chomp(|) {*} +multi sub chomp(Cool $s --> Str:D) { $s.chomp } + +proto sub flip(|) {*} +multi sub flip(Cool $s --> Str:D) { $s.flip } + +proto sub index(|) {*} +multi sub index(Cool $s, Cool $needle) { $s.index($needle) } +multi sub index(Cool $s, Cool $needle, Cool $pos) { $s.index($needle,$pos) } + +proto sub rindex(|) {*} +multi sub rindex(Cool $s, Cool $needle, Cool $pos) { $s.rindex($needle, $pos) } +multi sub rindex(Cool $s, Cool $needle) { $s.rindex($needle) } + +proto sub lc(|) {*} +multi sub lc(Cool $s) { $s.lc } + +proto sub ord(|) {*} +multi sub ord(Cool $s) { $s.ord } + +proto sub uc(|) {*} +multi sub uc(Cool $s) { $s.uc } + +proto sub tc(|) {*} +multi sub tc(Cool $s) { $s.tc } + +proto sub fc(|) {*} +multi sub fc(Cool $s) { $s.fc } + +proto sub tclc(|) {*} +multi sub tclc(Cool $s) { $s.tclc } + +proto sub indices(|) {*} +multi sub indices(Cool $s, |c) { $s.indices(|c) } + +proto sub ords($) {*} +multi sub ords(Cool:D $s) { $s.ords } + +proto sub comb($, $, $?) {*} +multi sub comb(Regex $matcher, Cool $input, $limit = *) { $input.comb($matcher, $limit) } +multi sub comb(Str $matcher, Cool $input, $limit = *) { $input.comb($matcher, $limit) } +multi sub comb(Int:D $matcher, Cool $input, $limit = *) { $input.comb($matcher, $limit) } + +proto sub wordcase($) is pure {*} +multi sub wordcase(Str:D $x) {$x.wordcase } +multi sub wordcase(Cool $x) {$x.Str.wordcase } + +proto sub sprintf(|) {*} +multi sub sprintf(Cool:D $format, *@args) { + CATCH { + when X::Cannot::Lazy { + X::Cannot::Lazy.new(:action('(s)printf')).throw + } + default { + Rakudo::Internals.HANDLE-NQP-SPRINTF-ERRORS($_).throw + } + } + Rakudo::Internals.initialize-sprintf-handler; + @args.elems; + nqp::p6box_s( + nqp::sprintf(nqp::unbox_s($format.Stringy), + nqp::clone(nqp::getattr(@args||[], List, '$!reified')) + ) + ) +} + +proto sub printf(|) {*} +multi sub printf(Cool:D $format, *@args) { print sprintf $format, @args } + +proto sub samecase(|) {*} +multi sub samecase(Cool:D $string, Cool:D $pattern) { $string.samecase($pattern) } + +proto sub split(|) {*} +multi sub split($pat, Cool:D $target, |c) { $target.split($pat, |c) } + +proto sub chars($) is pure {*} +multi sub chars(Cool $x) { $x.Str.chars } +multi sub chars(Str:D $x) { nqp::p6box_i(nqp::chars($x)) } +multi sub chars(str $x --> int) { nqp::chars($x) } + +# These probably belong in a separate unicodey file + +proto sub uniname(|) {*} +multi sub uniname(Str:D $str) { $str ?? uniname($str.ord) !! Nil } +multi sub uniname(Int:D $code) { nqp::getuniname($code) } + +proto sub uninames(|) {*} +multi sub uninames(Str:D $str) { $str.NFC.map: { uniname($_) } } + +#?if jvm +multi sub unival(|) { die 'unival NYI on jvm backend' } +multi sub univals(|) { die 'univals NYI on jvm backend' } +multi sub uniprop(|) { die 'uniprop NYI on jvm backend' } +multi sub uniprop-int(|) { die 'uniprop-int NYI on jvm backend' } +multi sub uniprop-bool(|) { die 'uniprop-bool NYI on jvm backend' } +multi sub uniprop-str(|) { die 'uniprop-str NYI on jvm backend' } +multi sub uniprops(|) { die 'uniprops NYI on jvm backend' } +multi sub unimatch(|) { die 'unimatch NYI on jvm backend' } +#?endif + +#?if moar +proto sub uniprop(|) {*} +multi sub uniprop(Str:D $str, |c) { $str ?? uniprop($str.ord, |c) !! Nil } +multi sub uniprop(Int:D $code) { + nqp::getuniprop_str($code,nqp::unipropcode('General_Category')); +} +multi sub uniprop(Int:D $code, Stringy:D $propname) { + # prop-mappings can be removed when MoarVM bug #448 is fixed... + ## The code below was generated by tools/build/makeUNIPROP.pl6 + my constant $prop-mappings = nqp::hash( + 'OGr_Ext','Other_Grapheme_Extend','tc','Titlecase_Mapping', + 'cjkIRG_MSource','kIRG_MSource','Dash','Dash','Pat_Syn','Pattern_Syntax', + 'IDST','IDS_Trinary_Operator','IDC','ID_Continue','Dia','Diacritic', + 'Cased','Cased','hst','Hangul_Syllable_Type','QMark','Quotation_Mark', + 'Radical','Radical','NFD_QC','NFD_Quick_Check','jt','Joining_Type', + 'cf','Case_Folding','cjkIRG_TSource','kIRG_TSource','sc','Script', + 'SD','Soft_Dotted','CWCM','Changes_When_Casemapped', + 'cjkOtherNumeric','kOtherNumeric','scf','Simple_Case_Folding', + 'sfc','Simple_Case_Folding','isc','ISO_Comment','na1','Unicode_1_Name', + 'Lower','Lowercase','Join_C','Join_Control','JSN','Jamo_Short_Name', + 'bc','Bidi_Class','jg','Joining_Group','dm','Decomposition_Mapping', + 'lc','Lowercase_Mapping','cjkIRG_USource','kIRG_USource', + 'NFKC_CF','NFKC_Casefold','slc','Simple_Lowercase_Mapping', + 'InSC','Indic_Syllabic_Category','XO_NFC','Expands_On_NFC', + 'XO_NFD','Expands_On_NFD','cjkAccountingNumeric','kAccountingNumeric', + 'Upper','Uppercase','WSpace','White_Space','space','White_Space', + 'cjkIRG_VSource','kIRG_VSource','STerm','Sentence_Terminal', + 'NFKD_QC','NFKD_Quick_Check','CWT','Changes_When_Titlecased','Math','Math', + 'uc','Uppercase_Mapping','NFKC_QC','NFKC_Quick_Check','SB','Sentence_Break', + 'stc','Simple_Titlecase_Mapping','Alpha','Alphabetic', + 'CE','Composition_Exclusion','NChar','Noncharacter_Code_Point', + 'OAlpha','Other_Alphabetic','XIDC','XID_Continue','age','Age', + 'cjkPrimaryNumeric','kPrimaryNumeric','OIDS','Other_ID_Start', + 'UIdeo','Unified_Ideograph','FC_NFKC','FC_NFKC_Closure','CI','Case_Ignorable', + 'Hyphen','Hyphen','nv','Numeric_Value','CWKCF','Changes_When_NFKC_Casefolded', + 'XO_NFKD','Expands_On_NFKD','InPC','Indic_Positional_Category', + 'dt','Decomposition_Type','cjkIICore','kIICore','Bidi_M','Bidi_Mirrored', + 'CWU','Changes_When_Uppercased','IDS','ID_Start','Gr_Ext','Grapheme_Extend', + 'XIDS','XID_Start','XO_NFKC','Expands_On_NFKC','OUpper','Other_Uppercase', + 'OMath','Other_Math','Gr_Link','Grapheme_Link','Bidi_C','Bidi_Control', + 'DI','Default_Ignorable_Code_Point','CWCF','Changes_When_Casefolded', + 'cjkIRG_GSource','kIRG_GSource','WB','Word_Break','NFC_QC','NFC_Quick_Check', + 'cjkIRG_JSource','kIRG_JSource','ODI','Other_Default_Ignorable_Code_Point', + 'LOE','Logical_Order_Exception','bpb','Bidi_Paired_Bracket', + 'PCM','Prepended_Concatenation_Mark','OLower','Other_Lowercase', + 'OIDC','Other_ID_Continue','VS','Variation_Selector','Ext','Extender', + 'Comp_Ex','Full_Composition_Exclusion','IDSB','IDS_Binary_Operator', + 'nt','Numeric_Type','cjkCompatibilityVariant','kCompatibilityVariant', + 'suc','Simple_Uppercase_Mapping','Term','Terminal_Punctuation', + 'lb','Line_Break','cjkIRG_HSource','kIRG_HSource','ea','East_Asian_Width', + 'AHex','ASCII_Hex_Digit','cjkIRG_KSource','kIRG_KSource', + 'Pat_WS','Pattern_White_Space','Hex','Hex_Digit', + 'cjkIRG_KPSource','kIRG_KPSource','bpt','Bidi_Paired_Bracket_Type', + 'gc','General_Category','GCB','Grapheme_Cluster_Break', + 'Gr_Base','Grapheme_Base','na','Name','scx','Script_Extensions', + 'Ideo','Ideographic','Name_Alias','Name_Alias','blk','Block','Dep','Deprecated', + 'CWL','Changes_When_Lowercased','bmg','Bidi_Mirroring_Glyph', + 'cjkRSUnicode','kRSUnicode','Unicode_Radical_Stroke','kRSUnicode', + 'URS','kRSUnicode','ccc','Canonical_Combining_Class', + ); + my constant $prefs = nqp::hash( + 'Other_Grapheme_Extend','B','Titlecase_Mapping','tc','Dash','B', + 'Emoji_Modifier_Base','B','Emoji_Modifier','B','Pattern_Syntax','B', + 'IDS_Trinary_Operator','B','ID_Continue','B','Diacritic','B','Cased','B', + 'Hangul_Syllable_Type','S','Quotation_Mark','B','Radical','B', + 'NFD_Quick_Check','S','Joining_Type','S','Case_Folding','S','Script','S', + 'Soft_Dotted','B','Changes_When_Casemapped','B','Simple_Case_Folding','S', + 'ISO_Comment','S','Lowercase','B','Join_Control','B','Bidi_Class','S', + 'Joining_Group','S','Decomposition_Mapping','S','Lowercase_Mapping','lc', + 'NFKC_Casefold','S','Simple_Lowercase_Mapping','S', + 'Indic_Syllabic_Category','S','Expands_On_NFC','B','Expands_On_NFD','B', + 'Uppercase','B','White_Space','B','Sentence_Terminal','B', + 'NFKD_Quick_Check','S','Changes_When_Titlecased','B','Math','B', + 'Uppercase_Mapping','uc','NFKC_Quick_Check','S','Sentence_Break','S', + 'Simple_Titlecase_Mapping','S','Alphabetic','B','Composition_Exclusion','B', + 'Noncharacter_Code_Point','B','Other_Alphabetic','B','XID_Continue','B', + 'Age','S','Other_ID_Start','B','Unified_Ideograph','B','FC_NFKC_Closure','S', + 'Case_Ignorable','B','Hyphen','B','Numeric_Value','nv', + 'Changes_When_NFKC_Casefolded','B','Expands_On_NFKD','B', + 'Indic_Positional_Category','S','Decomposition_Type','S','Bidi_Mirrored','B', + 'Changes_When_Uppercased','B','ID_Start','B','Grapheme_Extend','B', + 'XID_Start','B','Expands_On_NFKC','B','Other_Uppercase','B','Other_Math','B', + 'Grapheme_Link','B','Bidi_Control','B','Default_Ignorable_Code_Point','B', + 'Changes_When_Casefolded','B','Word_Break','S','NFC_Quick_Check','S', + 'Other_Default_Ignorable_Code_Point','B','Logical_Order_Exception','B', + 'Prepended_Concatenation_Mark','B','Other_Lowercase','B', + 'Other_ID_Continue','B','Variation_Selector','B','Extender','B', + 'Full_Composition_Exclusion','B','IDS_Binary_Operator','B','Numeric_Type','S', + 'kCompatibilityVariant','S','Simple_Uppercase_Mapping','S', + 'Terminal_Punctuation','B','Line_Break','S','East_Asian_Width','S', + 'ASCII_Hex_Digit','B','Pattern_White_Space','B','Hex_Digit','B', + 'Bidi_Paired_Bracket_Type','S','General_Category','S', + 'Grapheme_Cluster_Break','S','Grapheme_Base','B','Name','na','Ideographic','B', + 'Block','S','Emoji_Presentation','B','Emoji','B','Deprecated','B', + 'Changes_When_Lowercased','B','Bidi_Mirroring_Glyph','bmg', + 'Canonical_Combining_Class','S', + ); + ## End generated code + $propname := nqp::atkey($prop-mappings, $propname) if nqp::existskey($prop-mappings,$propname); + my $prop := nqp::unipropcode($propname); + my str $pref = nqp::ifnull(nqp::atkey($prefs, $propname),''); + nqp::if( + nqp::iseq_s($pref, 'S'), + nqp::getuniprop_str($code,$prop), + nqp::if( + nqp::iseq_s($pref, 'I'), + nqp::getuniprop_int($code,$prop), + nqp::if( + nqp::iseq_s($pref, 'B'), + nqp::p6bool(nqp::getuniprop_bool($code,$prop)), + nqp::if( + nqp::iseq_s($pref, 'lc'), + nqp::lc(nqp::chr(nqp::unbox_i($code))), + nqp::if( + nqp::iseq_s($pref, 'tc'), + nqp::tc(nqp::chr(nqp::unbox_i($code))), + nqp::if( + nqp::iseq_s($pref, 'uc'), + nqp::uc(nqp::chr(nqp::unbox_i($code))), + nqp::if( + nqp::iseq_s($pref, 'na'), + nqp::getuniname($code), + nqp::if( + nqp::iseq_s($pref, 'nv'), + unival($code), + nqp::if( + nqp::iseq_s($pref, 'bmg'), + nqp::stmts( + (my int $bmg-ord = nqp::getuniprop_int($code, $prop)), + $bmg-ord ?? nqp::chr($bmg-ord) !! ''), + nqp::stmts( + (my $result := nqp::getuniprop_str($code,$prop)), + nqp::if( + nqp::istrue($result), + nqp::stmts( + nqp::bindkey($prefs, $propname, 'S'), + $result), + nqp::stmts( + nqp::bindkey($prefs, $propname, 'I'), + nqp::getuniprop_int($code,$prop))))))))))))) +} +# Unicode functions +proto sub uniprop-int(|) {*} +multi sub uniprop-int(Str:D $str, Stringy:D $propname) { + $str ?? uniprop-int($str.ord, $propname) !! Nil } +multi sub uniprop-int(Int:D $code, Stringy:D $propname) { + nqp::getuniprop_int($code,nqp::unipropcode($propname)); +} + +proto sub uniprop-bool(|) {*} +multi sub uniprop-bool(Str:D $str, Stringy:D $propname) { + $str ?? uniprop-bool($str.ord, $propname) !! Nil +} +multi sub uniprop-bool(Int:D $code, Stringy:D $propname) { + nqp::p6bool(nqp::getuniprop_bool($code,nqp::unipropcode($propname))); +} + +proto sub uniprop-str(|) {*} +multi sub uniprop-str(Str:D $str, Stringy:D $propname) { + $str ?? uniprop-str($str.ord, $propname) !! Nil +} +multi sub uniprop-str(Int:D $code, Stringy:D $propname) { + nqp::getuniprop_str($code,nqp::unipropcode($propname)); +} +proto sub uniprops(|) {*} +multi sub uniprops(Str:D $str, Stringy:D $propname = "General_Category") { + $str.ords.map: { uniprop($_, $propname) } +} + +proto sub unival(|) {*} +multi sub unival(Str:D $str) { $str ?? unival($str.ord) !! Nil } +multi sub unival(Int:D $code) { + state $nuprop = nqp::unipropcode("Numeric_Value_Numerator"); + state $deprop = nqp::unipropcode("Numeric_Value_Denominator"); + my $nu = nqp::getuniprop_str($code, $nuprop); + my $de = nqp::getuniprop_str($code, $deprop); + !$de || $de eq '1' ?? $nu.Int !! $nu / $de; +} + +proto sub univals(|) {*} +multi sub univals(Str:D $str) { $str.ords.map: { unival($_) } } + +proto sub unimatch(|) {*} +multi sub unimatch(Str:D $str, |c) { $str ?? unimatch($str.ord, |c) !! Nil } +# This multi below can be removed when MoarVM bug #448 is fixed +multi sub unimatch(Int:D $code, Stringy:D $pvalname, Stringy:D $propname) { + uniprop($code, $propname) eq $pvalname; +} +multi sub unimatch(Int:D $code, Stringy:D $pvalname, Stringy:D $propname = $pvalname) { + my $prop := nqp::unipropcode($propname); + nqp::p6bool(nqp::matchuniprop($code,$prop,nqp::unipvalcode($prop,$pvalname))); +} +#?endif + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/core_epilogue.pm rakudo-2018.03/src/core/core_epilogue.pm --- rakudo-2018.02.1/src/core/core_epilogue.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/core_epilogue.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -# Re-parent meta-objects so they appear to be under Any. -BEGIN { - Perl6::Metamodel::ClassHOW.HOW.reparent(Perl6::Metamodel::ClassHOW, Any); - Perl6::Metamodel::ConcreteRoleHOW.HOW.reparent(Perl6::Metamodel::ConcreteRoleHOW, Any); - Perl6::Metamodel::CurriedRoleHOW.HOW.reparent(Perl6::Metamodel::CurriedRoleHOW, Any); - Perl6::Metamodel::EnumHOW.HOW.reparent(Perl6::Metamodel::EnumHOW, Any); - Perl6::Metamodel::GenericHOW.HOW.reparent(Perl6::Metamodel::GenericHOW, Any); - Perl6::Metamodel::ModuleHOW.HOW.reparent(Perl6::Metamodel::ModuleHOW, Any); - Perl6::Metamodel::NativeHOW.HOW.reparent(Perl6::Metamodel::NativeHOW, Any); - Perl6::Metamodel::PackageHOW.HOW.reparent(Perl6::Metamodel::PackageHOW, Any); - Perl6::Metamodel::ParametricRoleGroupHOW.HOW.reparent(Perl6::Metamodel::ParametricRoleGroupHOW, Any); - Perl6::Metamodel::ParametricRoleHOW.HOW.reparent(Perl6::Metamodel::ParametricRoleHOW, Any); - Perl6::Metamodel::SubsetHOW.HOW.reparent(Perl6::Metamodel::SubsetHOW, Any); - Perl6::Metamodel::GrammarHOW.HOW.compose(Perl6::Metamodel::GrammarHOW); - Perl6::Metamodel::BaseDispatcher.HOW.reparent(Perl6::Metamodel::BaseDispatcher, Any); - Perl6::Metamodel::MethodDispatcher.HOW.compose(Perl6::Metamodel::MethodDispatcher); - Perl6::Metamodel::MultiDispatcher.HOW.compose(Perl6::Metamodel::MultiDispatcher); - Perl6::Metamodel::WrapDispatcher.HOW.compose(Perl6::Metamodel::WrapDispatcher); -} - -BEGIN { - # Create pun at compile time as buf8 is used extensively in file I/O and module loading - buf8.elems; -} - -{ - my $perl := BEGIN Perl.new; - Rakudo::Internals.REGISTER-DYNAMIC: '$*PERL', { - PROCESS::<$PERL> := $perl; - } -} - -{YOU_ARE_HERE} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/core_epilogue.pm6 rakudo-2018.03/src/core/core_epilogue.pm6 --- rakudo-2018.02.1/src/core/core_epilogue.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/core_epilogue.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,35 @@ +# Re-parent meta-objects so they appear to be under Any. +BEGIN { + Perl6::Metamodel::ClassHOW.HOW.reparent(Perl6::Metamodel::ClassHOW, Any); + Perl6::Metamodel::ConcreteRoleHOW.HOW.reparent(Perl6::Metamodel::ConcreteRoleHOW, Any); + Perl6::Metamodel::CurriedRoleHOW.HOW.reparent(Perl6::Metamodel::CurriedRoleHOW, Any); + Perl6::Metamodel::EnumHOW.HOW.reparent(Perl6::Metamodel::EnumHOW, Any); + Perl6::Metamodel::GenericHOW.HOW.reparent(Perl6::Metamodel::GenericHOW, Any); + Perl6::Metamodel::ModuleHOW.HOW.reparent(Perl6::Metamodel::ModuleHOW, Any); + Perl6::Metamodel::NativeHOW.HOW.reparent(Perl6::Metamodel::NativeHOW, Any); + Perl6::Metamodel::PackageHOW.HOW.reparent(Perl6::Metamodel::PackageHOW, Any); + Perl6::Metamodel::ParametricRoleGroupHOW.HOW.reparent(Perl6::Metamodel::ParametricRoleGroupHOW, Any); + Perl6::Metamodel::ParametricRoleHOW.HOW.reparent(Perl6::Metamodel::ParametricRoleHOW, Any); + Perl6::Metamodel::SubsetHOW.HOW.reparent(Perl6::Metamodel::SubsetHOW, Any); + Perl6::Metamodel::GrammarHOW.HOW.compose(Perl6::Metamodel::GrammarHOW); + Perl6::Metamodel::BaseDispatcher.HOW.reparent(Perl6::Metamodel::BaseDispatcher, Any); + Perl6::Metamodel::MethodDispatcher.HOW.compose(Perl6::Metamodel::MethodDispatcher); + Perl6::Metamodel::MultiDispatcher.HOW.compose(Perl6::Metamodel::MultiDispatcher); + Perl6::Metamodel::WrapDispatcher.HOW.compose(Perl6::Metamodel::WrapDispatcher); +} + +BEGIN { + # Create pun at compile time as buf8 is used extensively in file I/O and module loading + buf8.elems; +} + +{ + my $perl := BEGIN Perl.new; + Rakudo::Internals.REGISTER-DYNAMIC: '$*PERL', { + PROCESS::<$PERL> := $perl; + } +} + +{YOU_ARE_HERE} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/core_prologue.pm rakudo-2018.03/src/core/core_prologue.pm --- rakudo-2018.02.1/src/core/core_prologue.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/core_prologue.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,49 +0,0 @@ -# Stub a few things the compiler wants to have really early on. -my class Pair { ... } # must be first for some reason -my class Block { ... } -my class HyperWhatever { ... } -my class List { ... } -my class Map { ... } -my class Match { ... } -my class Failure { ... } -my class Rakudo::Internals { ... } -my class Rakudo::Internals::JSON { ... } -my class Rakudo::Iterator { ... } -my class ThreadPoolScheduler { ... } -my class Whatever { ... } -my class WhateverCode { ... } -my class X::Attribute::Required { ... } -my class X::Numeric::Overflow { ... } -my class X::Numeric::Underflow { ... } - -# Stub these or we can't use any sigil other than $. -my role Positional { ... } -my role Associative { ... } -my role Callable { ... } -my role Iterable { ... } -my role PositionalBindFailover { ... } - -# Set up Empty, which is a Slip created with an empty IterationBuffer (which -# we also stub here). This is needed in a bunch of simple constructs (like if -# with only one branch). -my class IterationBuffer is repr('VMArray') { ... } -my constant Empty = nqp::p6bindattrinvres(nqp::create(Slip), - List, '$!reified', nqp::create(IterationBuffer)); - -# We use a sentinel value to mark the end of an iteration. -my constant IterationEnd = nqp::create(Mu); - -# To allow passing of nqp::hash without being HLLized, we create a HLL class -# with the same low level REPR as nqp::hash. -my class Rakudo::Internals::IterationSet is repr('VMHash') { } - -# The value for \n. -my constant $?NL = "\x0A"; - -# Make sure we have an environment -PROCESS::<%ENV> := Rakudo::Internals.createENV(0); - -# This thread pool scheduler will be the default one. -PROCESS::<$SCHEDULER> = ThreadPoolScheduler.new(); - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/core_prologue.pm6 rakudo-2018.03/src/core/core_prologue.pm6 --- rakudo-2018.02.1/src/core/core_prologue.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/core_prologue.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,49 @@ +# Stub a few things the compiler wants to have really early on. +my class Pair { ... } # must be first for some reason +my class Block { ... } +my class HyperWhatever { ... } +my class List { ... } +my class Map { ... } +my class Match { ... } +my class Failure { ... } +my class Rakudo::Internals { ... } +my class Rakudo::Internals::JSON { ... } +my class Rakudo::Iterator { ... } +my class ThreadPoolScheduler { ... } +my class Whatever { ... } +my class WhateverCode { ... } +my class X::Attribute::Required { ... } +my class X::Numeric::Overflow { ... } +my class X::Numeric::Underflow { ... } + +# Stub these or we can't use any sigil other than $. +my role Positional { ... } +my role Associative { ... } +my role Callable { ... } +my role Iterable { ... } +my role PositionalBindFailover { ... } + +# Set up Empty, which is a Slip created with an empty IterationBuffer (which +# we also stub here). This is needed in a bunch of simple constructs (like if +# with only one branch). +my class IterationBuffer is repr('VMArray') { ... } +my constant Empty = nqp::p6bindattrinvres(nqp::create(Slip), + List, '$!reified', nqp::create(IterationBuffer)); + +# We use a sentinel value to mark the end of an iteration. +my constant IterationEnd = nqp::create(Mu); + +# To allow passing of nqp::hash without being HLLized, we create a HLL class +# with the same low level REPR as nqp::hash. +my class Rakudo::Internals::IterationSet is repr('VMHash') { } + +# The value for \n. +my constant $?NL = "\x0A"; + +# Make sure we have an environment +PROCESS::<%ENV> := Rakudo::Internals.createENV(0); + +# This thread pool scheduler will be the default one. +PROCESS::<$SCHEDULER> = ThreadPoolScheduler.new(); + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CurrentThreadScheduler.pm rakudo-2018.03/src/core/CurrentThreadScheduler.pm --- rakudo-2018.02.1/src/core/CurrentThreadScheduler.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/CurrentThreadScheduler.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -# Scheduler that always does things immediately, on the current thread. - -my class CurrentThreadScheduler does Scheduler { - - method handle_uncaught($exception) { - $exception.throw - } - - method cue(&code, :$at, :$in, :$every, :$times = 1, :&catch is copy ) { - die "Cannot specify :at and :in at the same time" - if $at.defined and $in.defined; - die "Cannot specify :every and :times at the same time" - if $every.defined and $times > 1; - die "Cannot specify :every in {self.^name}" - if $every; - - my $delay = $at ?? $at - now !! $in; - sleep $delay if $delay; - &catch //= - (self && self.uncaught_handler) // -> $ex { self.handle_uncaught($ex) }; - - for 1 .. $times { - code(); - CATCH { default { catch($_) } }; - } - class { method cancel() {} } - } - - method loads(--> 0) { } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/CurrentThreadScheduler.pm6 rakudo-2018.03/src/core/CurrentThreadScheduler.pm6 --- rakudo-2018.02.1/src/core/CurrentThreadScheduler.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/CurrentThreadScheduler.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,32 @@ +# Scheduler that always does things immediately, on the current thread. + +my class CurrentThreadScheduler does Scheduler { + + method handle_uncaught($exception) { + $exception.throw + } + + method cue(&code, :$at, :$in, :$every, :$times = 1, :&catch is copy ) { + die "Cannot specify :at and :in at the same time" + if $at.defined and $in.defined; + die "Cannot specify :every and :times at the same time" + if $every.defined and $times > 1; + die "Cannot specify :every in {self.^name}" + if $every; + + my $delay = $at ?? $at - now !! $in; + sleep $delay if $delay; + &catch //= + (self && self.uncaught_handler) // -> $ex { self.handle_uncaught($ex) }; + + for 1 .. $times { + code(); + CATCH { default { catch($_) } }; + } + class { method cancel() {} } + } + + method loads(--> 0) { } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Cursor.pm rakudo-2018.03/src/core/Cursor.pm --- rakudo-2018.02.1/src/core/Cursor.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Cursor.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -my constant Cursor = Match; - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Cursor.pm6 rakudo-2018.03/src/core/Cursor.pm6 --- rakudo-2018.02.1/src/core/Cursor.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Cursor.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,3 @@ +my constant Cursor = Match; + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Dateish.pm rakudo-2018.03/src/core/Dateish.pm --- rakudo-2018.02.1/src/core/Dateish.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Dateish.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,147 +0,0 @@ -my role Dateish { - has Int $.year; - has Int $.month; # should be int - has Int $.day; # should be int - has Int $.daycount; - has &.formatter; - - method IO(Dateish:D:) { IO::Path.new(~self) } # because Dateish is not Cool - - # this sub is also used by DAYS-IN-MONTH, which is used by other types - sub IS-LEAP-YEAR($y) { $y %% 4 and not $y %% 100 or $y %% 400 } - method is-leap-year(Dateish:D:) { IS-LEAP-YEAR($!year) } - - my $days-in-month := nqp::list_i( - 0, 31, 0, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 - ); - # This method is used by Date and DateTime: - method DAYS-IN-MONTH(\year, \month) { - nqp::atpos_i($days-in-month,month) || - ( month == 2 ?? 28 + IS-LEAP-YEAR(year) !! Nil ); - } - method days-in-month(Dateish:D:) { self.DAYS-IN-MONTH($!year,$!month) } - - method !year-Str() { - sprintf 0 <= $!year <= 9999 ?? '%04d' !! '%+05d', $!year; - } - - multi method new(Dateish:) { - Failure.new( - "Cannot call {self.^name}.new with " - ~ (%_ ?? "these named parameters: {%_.keys}" !! "no parameters") - ) - } - - multi method Str(Dateish:D:) { - &!formatter ?? &!formatter(self) !! self!formatter - } - multi method gist(Dateish:D:) { self.Str } - - method daycount() { - $!daycount //= do { - # taken from - my int $m = $!month < 3 ?? $!month + 12 !! $!month; - my int $y = $!year - ($!month < 3); - -678973 + $!day + (153 * $m - 2) div 5 - + 365 * $y + $y div 4 - - $y div 100 + $y div 400; - } - } - - method !ymd-from-daycount($daycount,\year,\month,\day --> Nil) { - # taken from - my Int $dc = $daycount.Int + 678881; - my Int $ti = (4 * ($dc + 36525)) div 146097 - 1; - my Int $year = 100 * $ti; - my int $day = $dc - (36524 * $ti + ($ti div 4)); - my int $t = (4 * ($day + 366)) div 1461 - 1; - year = $year + $t; - $day = $day - (365 * $t + ($t div 4)); - my int $month = (5 * $day + 2) div 153; - day = $day - ((2 + $month * 153) div 5 - 1); - if ($month > 9) { - month = $month - 9; - year = year + 1; - } - else { - month = $month + 3; - } - } - - method day-of-month() { $!day } - method day-of-week(Dateish:D:) { (self.daycount + 2) % 7 + 1 } - - method week() { # algorithm from Claus Tøndering - my int $a = $!year - ($!month <= 2).floor.Int; - my int $b = $a div 4 - $a div 100 + $a div 400; - my int $c = ($a - 1) div 4 - ($a - 1) div 100 + ($a - 1) div 400; - my int $s = $b - $c; - my int $e = $!month <= 2 ?? 0 !! $s + 1; - my int $f = $!day - + ($!month <= 2 - ?? 31*($!month - 1) - 1 - !! (153*($!month - 3) + 2) div 5 + 58 + $s); - - my int $g = ($a + $b) % 7; - my int $d = ($f + $g - $e) % 7; - my int $n = $f + 3 - $d; - - $n < 0 ?? ($!year - 1, 53 - ($g - $s) div 5) - !! $n > 364 + $s ?? ($!year + 1, 1 ) - !! ($!year, $n div 7 + 1 ); - } - method week-year() { self.week.AT-POS(0) } - method week-number() { self.week.AT-POS(1) } - - method weekday-of-month { - ($!day - 1) div 7 + 1 - } - - my $days-at-start-of-month := nqp::list_i( - 0, 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 - ); - method day-of-year() { - $!day - + nqp::atpos_i($days-at-start-of-month,$!month) - + ($!month > 2 && IS-LEAP-YEAR($!year)); - } - - method yyyy-mm-dd() { sprintf '%04d-%02d-%02d',$!year,$!month,$!day } - - method earlier(*%unit) { self.later(:earlier, |%unit) } - - method !truncate-ymd(Cool:D $unit, %parts? is copy) { - if $unit eq 'week' | 'weeks' { - my $new-dc = self.daycount - self.day-of-week + 1; - self!ymd-from-daycount($new-dc, - %parts,%parts,%parts); - } - else { # $unit eq 'month' | 'months' | 'year' | 'years' - %parts = 1; - %parts = 1 if $unit eq 'year' | 'years'; - } - %parts; - } -} - -# =begin pod -# -# =head1 SEE ALSO -# Perl 6 spec . -# The Perl 5 DateTime Project home page L. -# Perl 5 perldoc L and L. -# -# The best yet seen explanation of calendars, by Claus Tøndering -# L. -# Similar algorithms at L -# and L. -# -# -#
), :actions($LANG)) if $LANG); - - $*W.add_additional_frames(mast_frames) - if $*W and $*W.is_precompilation_mode; # we are still compiling - nqp::forceouterctx(nqp::getattr($compiled, ForeignCode, '$!do'), $eval_ctx); - $compiled(); -} - -multi sub EVAL($code, Str :$lang where { ($lang // '') eq 'Perl5' }, PseudoStash :$context) { - my $eval_ctx := nqp::getattr(nqp::decont($context // CALLER::), PseudoStash, '$!ctx'); - my $?FILES := 'EVAL_' ~ (state $no)++; - state $p5; - unless $p5 { - { - my $compunit := $*REPO.need(CompUnit::DependencySpecification.new(:short-name)); - GLOBAL.WHO.merge-symbols($compunit.handle.globalish-package); - CATCH { - #X::Eval::NoSuchLang.new(:$lang).throw; - note $_; - } - } - $p5 = ::("Inline::Perl5").default_perl5; - } - $p5.run: nqp::istype($code,Blob) - ?? Blob.new($code).decode('utf8-c8') - !! $code.Str; -} - -proto sub EVALFILE($, *%) {*} -multi sub EVALFILE($filename, :$lang = 'perl6') { - EVAL slurp(:bin, $filename), :$lang, :context(CALLER::); -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/ForeignCode.pm6 rakudo-2018.03/src/core/ForeignCode.pm6 --- rakudo-2018.02.1/src/core/ForeignCode.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/ForeignCode.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,94 @@ +# Takes a foreign code object and tries to make it feel somewhat like a Perl +# 6 one. Note that it doesn't have signature information we can know about. + +my class ForeignCode does Callable { # declared in BOOTSTRAP + # class ForeignCode + # has Code $!do; # Code object we delegate to + + method arity() { self.signature.arity } + + method count() { self.signature.count } + + method signature(ForeignCode:D:) { (sub (|) { }).signature } + + method name() { (nqp::can($!do, 'name') ?? $!do.name !! nqp::getcodename($!do)) || '' } + + multi method gist(ForeignCode:D:) { self.name } + + multi method Str(ForeignCode:D:) { self.name } +} + +my class Rakudo::Internals::EvalIdSource { + my Int $count = 0; + my Lock $lock = Lock.new; + method next-id() { + $lock.protect: { $count++ } + } +} +proto sub EVAL($code is copy where Blob|Cool|Callable, Str() :$lang = 'perl6', PseudoStash :$context, *%n) { + die "EVAL() in Perl 6 is intended to evaluate strings, did you mean 'try'?" + if nqp::istype($code,Callable); + # First look in compiler registry. + my $compiler := nqp::getcomp($lang); + if nqp::isnull($compiler) { + # Try a multi-dispatch to another EVAL candidate. If that fails to + # dispatch, map it to a typed exception. + CATCH { + when X::Multi::NoMatch { + X::Eval::NoSuchLang.new(:$lang).throw + } + } + return {*}; + } + $code = nqp::istype($code,Blob) ?? $code.decode( + $compiler.cli-options // 'utf8' + ) !! $code.Str; + + $context := CALLER:: unless nqp::defined($context); + my $eval_ctx := nqp::getattr(nqp::decont($context), PseudoStash, '$!ctx'); + my $?FILES := 'EVAL_' ~ Rakudo::Internals::EvalIdSource.next-id; + my \mast_frames := nqp::hash(); + my $*CTXSAVE; # make sure we don't use the EVAL's MAIN context for the + # currently compiling compilation unit + + my $LANG := $context<%?LANG> || CALLERS::<%?LANG>; + my $compiled := $compiler.compile: + $code, + :outer_ctx($eval_ctx), + :global(GLOBAL), + :mast_frames(mast_frames), + |(:optimize($_) with nqp::getcomp('perl6').cli-options), + |(%(:grammar($LANG
), :actions($LANG)) if $LANG); + + $*W.add_additional_frames(mast_frames) + if $*W and $*W.is_precompilation_mode; # we are still compiling + nqp::forceouterctx(nqp::getattr($compiled, ForeignCode, '$!do'), $eval_ctx); + $compiled(); +} + +multi sub EVAL($code, Str :$lang where { ($lang // '') eq 'Perl5' }, PseudoStash :$context) { + my $eval_ctx := nqp::getattr(nqp::decont($context // CALLER::), PseudoStash, '$!ctx'); + my $?FILES := 'EVAL_' ~ (state $no)++; + state $p5; + unless $p5 { + { + my $compunit := $*REPO.need(CompUnit::DependencySpecification.new(:short-name)); + GLOBAL.WHO.merge-symbols($compunit.handle.globalish-package); + CATCH { + #X::Eval::NoSuchLang.new(:$lang).throw; + note $_; + } + } + $p5 = ::("Inline::Perl5").default_perl5; + } + $p5.run: nqp::istype($code,Blob) + ?? Blob.new($code).decode('utf8-c8') + !! $code.Str; +} + +proto sub EVALFILE($, *%) {*} +multi sub EVALFILE($filename, :$lang = 'perl6') { + EVAL slurp(:bin, $filename), :$lang, :context(CALLER::); +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Grammar.pm rakudo-2018.03/src/core/Grammar.pm --- rakudo-2018.02.1/src/core/Grammar.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Grammar.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,69 +0,0 @@ -my class Grammar is Match { - - method parse(\target, :$rule, :$args, Mu :$actions, :$filename) is raw { - my $*LINEPOSCACHE; - nqp::stmts( - (my $grammar := self.new(:orig(target), |%_).set_actions($actions)), - nqp::decont(nqp::getlexcaller('$/') = - nqp::if( - (my $cursor := nqp::if( - $rule, - nqp::if( - $args, - $grammar."$rule"(|$args.Capture), - $grammar."$rule"() - ), - nqp::if( - $args, - $grammar.TOP(|$args.Capture), - $grammar.TOP() - ), - )), - nqp::stmts( - (my $match := $cursor.MATCH), - nqp::while( - $match && nqp::isne_i( - nqp::getattr_i(($match := $cursor.MATCH),Match,'$!pos'), - target.chars - ), - $match := ($cursor := $cursor.'!cursor_next'()).MATCH - ), - $match || Nil - ), - Nil - ) - ) - ) - } - - method subparse(\target, :$rule, :$args, :$actions) is raw { - nqp::stmts( - (my $grammar := self.new(:orig(target), |%_).set_actions($actions)), - nqp::decont(nqp::getlexcaller('$/') = - nqp::if( - $rule, - nqp::if( - $args, - $grammar."$rule"(|$args.Capture).MATCH, - $grammar."$rule"().MATCH, - ), - nqp::if( - $args, - $grammar.TOP(|$args.Capture).MATCH, - $grammar.TOP().MATCH - ), - ) - ) - ) - } - - method parsefile(Str(Cool) $filename, :$enc) is raw { - nqp::decont(nqp::getlexcaller('$/') = nqp::if( - nqp::elems(nqp::getattr(%_,Map,'$!storage')), - self.parse($filename.IO.slurp(:$enc), :$filename, |%_), - self.parse($filename.IO.slurp(:$enc), :$filename) - )) - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Grammar.pm6 rakudo-2018.03/src/core/Grammar.pm6 --- rakudo-2018.02.1/src/core/Grammar.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Grammar.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,69 @@ +my class Grammar is Match { + + method parse(\target, :$rule, :$args, Mu :$actions, :$filename) is raw { + my $*LINEPOSCACHE; + nqp::stmts( + (my $grammar := self.new(:orig(target), |%_).set_actions($actions)), + nqp::decont(nqp::getlexcaller('$/') = + nqp::if( + (my $cursor := nqp::if( + $rule, + nqp::if( + $args, + $grammar."$rule"(|$args.Capture), + $grammar."$rule"() + ), + nqp::if( + $args, + $grammar.TOP(|$args.Capture), + $grammar.TOP() + ), + )), + nqp::stmts( + (my $match := $cursor.MATCH), + nqp::while( + $match && nqp::isne_i( + nqp::getattr_i(($match := $cursor.MATCH),Match,'$!pos'), + target.chars + ), + $match := ($cursor := $cursor.'!cursor_next'()).MATCH + ), + $match || Nil + ), + Nil + ) + ) + ) + } + + method subparse(\target, :$rule, :$args, :$actions) is raw { + nqp::stmts( + (my $grammar := self.new(:orig(target), |%_).set_actions($actions)), + nqp::decont(nqp::getlexcaller('$/') = + nqp::if( + $rule, + nqp::if( + $args, + $grammar."$rule"(|$args.Capture).MATCH, + $grammar."$rule"().MATCH, + ), + nqp::if( + $args, + $grammar.TOP(|$args.Capture).MATCH, + $grammar.TOP().MATCH + ), + ) + ) + ) + } + + method parsefile(Str(Cool) $filename, :$enc) is raw { + nqp::decont(nqp::getlexcaller('$/') = nqp::if( + nqp::elems(nqp::getattr(%_,Map,'$!storage')), + self.parse($filename.IO.slurp(:$enc), :$filename, |%_), + self.parse($filename.IO.slurp(:$enc), :$filename) + )) + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Hash.pm rakudo-2018.03/src/core/Hash.pm --- rakudo-2018.02.1/src/core/Hash.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Hash.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,845 +0,0 @@ -my class X::Invalid::ComputedValue { ... }; - -my class Hash { # declared in BOOTSTRAP - # my class Hash is Map - # has Mu $!descriptor; - - multi method WHICH(Hash:D:) { self.Mu::WHICH } - multi method Hash(Hash:) { - self - } - multi method Map(Hash:U:) { Map } - multi method Map(Hash:D: :$view) { - my $hash := nqp::getattr(self,Map,'$!storage'); - - # empty - if nqp::not_i(nqp::defined($hash)) { - nqp::create(Map) - } - - # view, assuming no change in hash - elsif $view { - nqp::p6bindattrinvres(nqp::create(Map),Map,'$!storage',$hash) - } - - # make cow copy - else { - my $map := nqp::hash; - my \iter := nqp::iterator($hash); - my str $key; - nqp::while( - iter, - nqp::bindkey( - $map, - ($key = nqp::iterkey_s(nqp::shift(iter))), - nqp::decont(nqp::atkey($hash,$key)) - ) - ); - nqp::p6bindattrinvres(nqp::create(Map),Map,'$!storage',$map) - } - } - method clone(Hash:D:) is raw { - nqp::p6bindattrinvres( - nqp::p6bindattrinvres( - nqp::create(self),Map,'$!storage', - nqp::clone(nqp::getattr(self,Map,'$!storage'))), - Hash, '$!descriptor', nqp::isnull($!descriptor) ?? (nqp::null) !! nqp::clone($!descriptor)) - } - - method !AT-KEY-CONTAINER(Str:D \key) is raw { - nqp::p6bindattrinvres( - (my \v := nqp::p6scalarfromdesc($!descriptor)), - Scalar, - '$!whence', - -> { nqp::bindkey( - nqp::if( - nqp::isconcrete(nqp::getattr(self,Map,'$!storage')), - nqp::getattr(self,Map,'$!storage'), - nqp::bindattr(self,Map,'$!storage',nqp::hash) - ),key,v) - } - ) - } - - multi method AT-KEY(Hash:D: Str:D \key) is raw { - nqp::if( - nqp::isconcrete(nqp::getattr(self,Map,'$!storage')), - nqp::ifnull( - nqp::atkey(nqp::getattr(self,Map,'$!storage'),key), - self!AT-KEY-CONTAINER(key) - ), - self!AT-KEY-CONTAINER(key) - ) - } - multi method AT-KEY(Hash:D: \key) is raw { - nqp::if( - nqp::isconcrete(nqp::getattr(self,Map,'$!storage')), - nqp::ifnull( - nqp::atkey(nqp::getattr(self,Map,'$!storage'),key.Str), - self!AT-KEY-CONTAINER(key.Str) - ), - self!AT-KEY-CONTAINER(key.Str) - ) - } - - multi method STORE_AT_KEY(Str:D \key, Mu \x --> Nil) { - nqp::bindkey( - nqp::getattr(self,Map,'$!storage'), - nqp::unbox_s(key), - (nqp::p6scalarfromdesc($!descriptor) = x), - ) - } - multi method STORE_AT_KEY(\key, Mu \x --> Nil) { - nqp::bindkey( - nqp::getattr(self,Map,'$!storage'), - nqp::unbox_s(key.Str), - (nqp::p6scalarfromdesc($!descriptor) = x), - ) - } - - multi method ASSIGN-KEY(Hash:D: Str:D \key, Mu \assignval) is raw { - nqp::if( - nqp::getattr(self,Map,'$!storage').DEFINITE, - (nqp::ifnull( - nqp::atkey( - nqp::getattr(self,Map,'$!storage'), - nqp::unbox_s(key) - ), - nqp::bindkey( - nqp::getattr(self,Map,'$!storage'), - nqp::unbox_s(key), - nqp::p6scalarfromdesc($!descriptor) - ) - ) = assignval), - nqp::bindkey( - nqp::bindattr(self,Map,'$!storage',nqp::hash), - nqp::unbox_s(key), - nqp::p6scalarfromdesc($!descriptor) = assignval - ) - ) - } - multi method ASSIGN-KEY(Hash:D: \key, Mu \assignval) is raw { - nqp::if( - nqp::getattr(self,Map,'$!storage').DEFINITE, - (nqp::ifnull( - nqp::atkey( - nqp::getattr(self,Map,'$!storage'), - nqp::unbox_s(key.Str) - ), - nqp::bindkey( - nqp::getattr(self,Map,'$!storage'), - nqp::unbox_s(key.Str), - nqp::p6scalarfromdesc($!descriptor) - ) - ) = assignval), - nqp::bindkey( - nqp::bindattr(self,Map,'$!storage',nqp::hash), - nqp::unbox_s(key.Str), - nqp::p6scalarfromdesc($!descriptor) = assignval - ) - ) - } - - # for some reason, this can't be turned into a multi without - # making setting compilation get very confused indeed - method BIND-KEY(Hash:D: \key, Mu \bindval) is raw { - nqp::bindattr(self,Map,'$!storage',nqp::hash) - unless nqp::defined(nqp::getattr(self,Map,'$!storage')); - nqp::bindkey(nqp::getattr(self,Map,'$!storage'), - nqp::unbox_s(nqp::istype(key,Str) ?? key !! key.Str), bindval) - } - - multi method DELETE-KEY(Hash:U: --> Nil) { } - multi method DELETE-KEY(Hash:D: Str:D \key) { - nqp::if( - (nqp::getattr(self,Map,'$!storage').DEFINITE - && nqp::existskey(nqp::getattr(self,Map,'$!storage'), - nqp::unbox_s(key))), - nqp::stmts( - (my $value = nqp::atkey(nqp::getattr(self,Map,'$!storage'), - nqp::unbox_s(key))), - nqp::deletekey(nqp::getattr(self,Map,'$!storage'), - nqp::unbox_s(key)), - $value - ), - nqp::p6scalarfromdesc($!descriptor) - ) - } - multi method DELETE-KEY(Hash:D: \key) { - nqp::stmts( - (my str $key = nqp::unbox_s(key.Str)), - nqp::if( - (nqp::getattr(self,Map,'$!storage').DEFINITE - && nqp::existskey(nqp::getattr(self,Map,'$!storage'),$key)), - nqp::stmts( - (my $value = nqp::atkey(nqp::getattr(self,Map,'$!storage'),$key)), - nqp::deletekey(nqp::getattr(self,Map,'$!storage'),$key), - $value - ), - nqp::p6scalarfromdesc($!descriptor) - ) - ) - } - - multi method perl(Hash:D \SELF:) { - SELF.perlseen(self.^name, { - '$' x nqp::iscont(SELF) # self is always deconted - ~ '{' ~ self.sort.map({.perl}).join(', ') ~ '}' - }) - } - - multi method gist(Hash:D:) { - self.gistseen(self.^name, { - '{' ~ - self.sort.map({ - state $i = 0; - ++$i == 101 ?? '...' - !! $i == 102 ?? last() - !! .gist - }).join(', ') - ~ '}' - }) - } - - multi method DUMP(Hash:D: :$indent-step = 4, :%ctx) { - nqp::if( - %ctx, - self.DUMP-OBJECT-ATTRS( - nqp::list( - '$!descriptor', - $!descriptor, - '$!storage', - nqp::getattr(nqp::decont(self),Map,'$!storage') - ), - :$indent-step, - :%ctx - ), - DUMP(self, :$indent-step) - ) - } - - # introspection - method name() { - nqp::isnull($!descriptor) ?? Nil !! $!descriptor.name - } - method keyof() { - Str(Any) - } - method of() { - nqp::isnull($!descriptor) ?? Mu !! $!descriptor.of - } - method default() { - nqp::isnull($!descriptor) ?? Any !! $!descriptor.default - } - method dynamic() { - nqp::isnull($!descriptor) ?? False !! nqp::p6bool($!descriptor.dynamic) - } - - method push(+values) { - fail X::Cannot::Lazy.new(:action, :what(self.^name)) - if values.is-lazy; - - my $previous; - my int $has_previous = 0; - - nqp::if( - $has_previous, - nqp::stmts( - self!_push_construct($previous,$_), - ($has_previous = 0) - ), - nqp::if( - nqp::istype($_,Pair), - self!_push_construct(.key,.value), - nqp::stmts( - ($previous := $_), - ($has_previous = 1) - ) - ) - ) for values; - - warn "Trailing item in {self.^name}.push" if $has_previous; - self - } - - method append(+values) { - fail X::Cannot::Lazy.new(:action, :what(self.^name)) - if values.is-lazy; - - my $previous; - my int $has_previous = 0; - - nqp::if( - $has_previous, - nqp::stmts( - self!_append_construct($previous,$_), - ($has_previous = 0) - ), - nqp::if( - nqp::istype($_,Pair), - self!_append_construct(.key,.value), - nqp::stmts( - ($previous := $_), - ($has_previous = 1) - ) - ) - ) for values; - - warn "Trailing item in {self.^name}.append" if $has_previous; - self - } - - proto method classify-list(|) {*} - multi method classify-list( &test, \list, :&as ) { - fail X::Cannot::Lazy.new(:action) if list.is-lazy; - my \iter = (nqp::istype(list, Iterable) ?? list !! list.list).iterator; - my $value := iter.pull-one; - unless $value =:= IterationEnd { - my $tested := test($value); - - # multi-level classify - if nqp::istype($tested, Iterable) { - my $els = $tested.elems; - loop { - my @keys = @$tested; - @keys == $els or X::Invalid::ComputedValue.new( - :name, - :method, - :value('an item with different number of elements ' - ~ 'in it than previous items'), - :reason('all values need to have the same number ' - ~ 'of elements. Mixed-level classification is ' - ~ 'not supported.'), - ).throw; - my $last := @keys.pop; - my $hash = self; - $hash = $hash{$_} //= self.new for @keys; - $hash{$last}.push(&as ?? as($value) !! $value); - last if ($value := iter.pull-one) =:= IterationEnd; - $tested := test($value); - }; - } - # just a simple classify - else { - loop { - self{$tested}.push(&as ?? as($value) !! $value); - last if ($value := iter.pull-one) =:= IterationEnd; - nqp::istype(($tested := test($value)), Iterable) - and X::Invalid::ComputedValue.new( - :name, - :method, - :value('an item with different number of elements ' - ~ 'in it than previous items'), - :reason('all values need to have the same number ' - ~ 'of elements. Mixed-level classification is ' - ~ 'not supported.'), - ).throw; - }; - } - } - self; - } - multi method classify-list( %test, |c ) { - self.classify-list( { %test{$^a} }, |c ); - } - multi method classify-list( @test, |c ) { - self.classify-list( { @test[$^a] }, |c ); - } - multi method classify-list(&test, **@list, |c) { - self.classify-list(&test, @list, |c); - } - - proto method categorize-list(|) {*} - multi method categorize-list( &test, \list, :&as ) { - fail X::Cannot::Lazy.new(:action) if list.is-lazy; - my \iter = (nqp::istype(list, Iterable) ?? list !! list.list).iterator; - my $value := iter.pull-one; - unless $value =:= IterationEnd { - my $tested := test($value); - - # multi-level categorize - if nqp::istype($tested[0],Iterable) { - my $els = $tested[0].elems; - loop { - for $tested.cache -> $cat { - my @keys = @$cat or next; - my $last := @keys.pop; - my $hash = self; - $hash = $hash{$_} //= self.new for @keys; - $hash{$last}.push(&as ?? as($value) !! $value); - } - - last if ($value := iter.pull-one) =:= IterationEnd; - $tested := test($value); - - nqp::istype($tested[0],Iterable) - and $els == $tested[0] - or X::Invalid::ComputedValue.new( - :name, - :method, - :value('an item with different number of elements ' - ~ 'in it than previous items'), - :reason('all values need to have the same number ' - ~ 'of elements. Mixed-level classification is ' - ~ 'not supported.'), - ).throw; - } - } - # simple categorize - else { - loop { - self{$_}.push(&as ?? as($value) !! $value) - for @$tested; - last if ($value := iter.pull-one) =:= IterationEnd; - nqp::istype(($tested := test($value))[0], Iterable) - and X::Invalid::ComputedValue.new( - :name, - :method, - :value('an item with different number of elements ' - ~ 'in it than previous items'), - :reason('all values need to have the same number ' - ~ 'of elements. Mixed-level classification is ' - ~ 'not supported.'), - ).throw; - }; - } - } - self; - } - multi method categorize-list( %test, |c ) { - self.categorize-list( { %test{$^a} }, |c ); - } - multi method categorize-list( @test, |c ) { - self.categorize-list( { @test[$^a] }, |c ); - } - multi method categorize-list( &test, **@list, |c ) { - self.categorize-list( &test, @list, |c ); - } - - # push a value onto a hash slot, constructing an array if necessary - method !_push_construct(Mu $key, Mu \value --> Nil) { - self.EXISTS-KEY($key) - ?? self.AT-KEY($key).^isa(Array) - ?? self.AT-KEY($key).push(value) - !! self.ASSIGN-KEY($key,[self.AT-KEY($key),value]) - !! self.ASSIGN-KEY($key,value) - } - - # append values into a hash slot, constructing an array if necessary - method !_append_construct(Mu $key, Mu \value --> Nil) { - self.EXISTS-KEY($key) - ?? self.AT-KEY($key).^isa(Array) - ?? self.AT-KEY($key).append(|value) - !! self.ASSIGN-KEY($key,[|self.AT-KEY($key),|value]) - !! self.ASSIGN-KEY($key,value) - } - - my role TypedHash[::TValue] does Associative[TValue] { - # These ASSIGN-KEY candidates are only needed because of: - # my Int %h; try %h = "foo"; dd %h - # leaving an uninitialized Int for key in the hash. If - # we could live with that, then these candidates can be - # removed. However, there are spectest covering this - # eventuality, so to appease roast, we need these. - multi method ASSIGN-KEY(::?CLASS:D: Str:D \key, Mu \assignval) is raw { - nqp::if( - nqp::getattr(self,Map,'$!storage').DEFINITE, - nqp::if( - nqp::existskey( - nqp::getattr(self,Map,'$!storage'), - nqp::unbox_s(key) - ), - (nqp::atkey( - nqp::getattr(self,Map,'$!storage'), - nqp::unbox_s(key) - ) = assignval), - nqp::bindkey( - nqp::getattr(self,Map,'$!storage'), - nqp::unbox_s(key), - nqp::p6scalarfromdesc( - nqp::getattr(self,Hash,'$!descriptor')) = assignval - ) - ), - nqp::bindkey( - nqp::bindattr(self,Map,'$!storage',nqp::hash), - nqp::unbox_s(key), - nqp::p6scalarfromdesc( - nqp::getattr(self,Hash,'$!descriptor')) = assignval - ) - ) - } - multi method ASSIGN-KEY(::?CLASS:D: \key, Mu \assignval) is raw { - nqp::stmts( - (my str $key = nqp::unbox_s(key.Str)), - nqp::if( - nqp::getattr(self,Map,'$!storage').DEFINITE, - nqp::if( - nqp::existskey( - nqp::getattr(self,Map,'$!storage'), - $key - ), - (nqp::atkey( - nqp::getattr(self,Map,'$!storage'), - $key - ) = assignval), - nqp::bindkey( - nqp::getattr(self,Map,'$!storage'), - nqp::unbox_s(key.Str), - nqp::p6scalarfromdesc( - nqp::getattr(self,Hash,'$!descriptor')) = assignval - ) - ), - nqp::bindkey( - nqp::bindattr(self,Map,'$!storage',nqp::hash), - $key, - nqp::p6scalarfromdesc( - nqp::getattr(self,Hash,'$!descriptor')) = assignval - ) - ) - ) - } - multi method perl(::?CLASS:D \SELF:) { - SELF.perlseen('Hash', { - '$' x nqp::iscont(SELF) # self is always deconted - ~ (self.elems - ?? "(my {TValue.perl} % = { - self.sort.map({.perl}).join(', ') - })" - !! "(my {TValue.perl} %)" - ) - }) - } - } - my role TypedHash[::TValue, ::TKey] does Associative[TValue] { - method keyof () { TKey } - method AT-KEY(::?CLASS:D: TKey \key) is raw { - nqp::if( - nqp::getattr(self,Map,'$!storage').DEFINITE, - nqp::if( - nqp::existskey(nqp::getattr(self,Map,'$!storage'), - (my str $which = nqp::unbox_s(key.WHICH))), - nqp::getattr( - nqp::atkey(nqp::getattr(self,Map,'$!storage'),$which), - Pair,'$!value'), - nqp::p6bindattrinvres( - (my \v := nqp::p6scalarfromdesc( - nqp::getattr(self,Hash,'$!descriptor'))), - Scalar, - '$!whence', - -> { nqp::bindkey(nqp::getattr(self,Map,'$!storage'), - $which,Pair.new(key,v)); v } - ) - ), - nqp::p6bindattrinvres( - (my \vv := nqp::p6scalarfromdesc( - nqp::getattr(self,Hash,'$!descriptor'))), - Scalar, - '$!whence', - -> { nqp::bindkey( - nqp::if( - nqp::getattr(self,Map,'$!storage').DEFINITE, - nqp::getattr(self,Map,'$!storage'), - nqp::bindattr(self,Map,'$!storage',nqp::hash) - ), - nqp::unbox_s(key.WHICH), Pair.new(key,vv)); vv } - ) - ) - } - - method STORE_AT_KEY(TKey \key, TValue \x --> Nil) { - nqp::bindkey( - nqp::getattr(self,Map,'$!storage'), - nqp::unbox_s(key.WHICH), - Pair.new( - key, - nqp::p6scalarfromdesc(nqp::getattr(self,Hash,'$!descriptor')) - = x - ) - ) - } - - method ASSIGN-KEY(::?CLASS:D: TKey \key, TValue \assignval) is raw { - nqp::if( - nqp::getattr(self,Map,'$!storage').DEFINITE, - nqp::if( - nqp::existskey(nqp::getattr(self,Map,'$!storage'), - my str $which = nqp::unbox_s(key.WHICH)), - (nqp::getattr( - nqp::atkey(nqp::getattr(self,Map,'$!storage'),$which), - Pair,'$!value') = assignval), - nqp::getattr( - (nqp::bindkey(nqp::getattr(self,Map,'$!storage'),$which, - Pair.new(key,nqp::p6scalarfromdesc( - nqp::getattr(self,Hash,'$!descriptor')) = assignval))), - Pair,'$!value') - ), - nqp::getattr( - (nqp::bindkey(nqp::bindattr(self,Map,'$!storage',nqp::hash), - nqp::unbox_s(key.WHICH), - Pair.new(key,nqp::p6scalarfromdesc( - nqp::getattr(self,Hash,'$!descriptor')) = assignval))), - Pair,'$!value') - ) - } - - method BIND-KEY(TKey \key, TValue \bindval) is raw { - nqp::getattr( - nqp::if( - nqp::getattr(self,Map,'$!storage').DEFINITE, - nqp::bindkey(nqp::getattr(self,Map,'$!storage'), - nqp::unbox_s(key.WHICH), - Pair.new(key,bindval)), - nqp::bindkey(nqp::bindattr(self,Map,'$!storage',nqp::hash), - nqp::unbox_s(key.WHICH), - Pair.new(key,bindval)) - ), - Pair,'$!value' - ) - } - - method EXISTS-KEY(TKey \key) { - nqp::p6bool( - nqp::defined(nqp::getattr(self,Map,'$!storage')) - && nqp::existskey(nqp::getattr(self,Map,'$!storage'),key.WHICH) - ) - } - - method DELETE-KEY(TKey \key) { - nqp::if( - (nqp::getattr(self,Map,'$!storage').DEFINITE - && nqp::existskey(nqp::getattr(self,Map,'$!storage'), - (my str $which = key.WHICH))), - nqp::stmts( - (my TValue $value = - nqp::getattr( - nqp::atkey(nqp::getattr(self,Map,'$!storage'),$which), - Pair,'$!value')), - nqp::deletekey(nqp::getattr(self,Map,'$!storage'),$which), - $value - ), - TValue - ) - } - - method FLATTENABLE_HASH() { - nqp::stmts( - (my $flattened := nqp::hash), - nqp::if( - (my $raw := nqp::getattr(self,Map,'$!storage')) - && (my $iter := nqp::iterator($raw)), - nqp::while( - $iter, - nqp::bindkey( - $flattened, - nqp::if( - nqp::istype( - (my $key := nqp::getattr( - nqp::iterval(nqp::shift($iter)), - Pair, - '$!key' - )), - Str, - ), - $key, - $key.Str - ), - nqp::getattr(nqp::iterval($iter),Pair,'$!value') - ) - ) - ), - $flattened - ) - } - - method IterationBuffer() { - nqp::stmts( - (my $buffer := nqp::create(IterationBuffer)), - nqp::if( - nqp::defined( - nqp::getattr(self,Map,'$!storage') - ) && nqp::elems( - nqp::getattr(self,Map,'$!storage') - ), - nqp::stmts( - (my $iterator := nqp::iterator( - nqp::getattr(self,Map,'$!storage') - )), - nqp::setelems($buffer,nqp::elems( - nqp::getattr(self,Map,'$!storage') - )), - (my int $i = -1), - nqp::while( - $iterator, - nqp::bindpos($buffer,($i = nqp::add_i($i,1)), - nqp::iterval(nqp::shift($iterator))) - ) - ) - ), - $buffer - ) - } - - method keys() { - Seq.new(class :: does Rakudo::Iterator::Mappy { - method pull-one() { - nqp::if( - $!iter, - nqp::getattr(nqp::iterval(nqp::shift($!iter)), - Pair,'$!key'), - IterationEnd - ) - } - }.new(self)) - } - method values() { - Seq.new(class :: does Rakudo::Iterator::Mappy { - method pull-one() { - nqp::if( - $!iter, - nqp::getattr(nqp::iterval(nqp::shift($!iter)), - Pair,'$!value'), - IterationEnd - ) - } - }.new(self)) - } - method kv() { - Seq.new(Rakudo::Iterator.Mappy-kv-from-pairs(self)) - } - method iterator() { Rakudo::Iterator.Mappy-values(self) } - method antipairs() { - Seq.new(class :: does Rakudo::Iterator::Mappy { - method pull-one() { - nqp::if( - $!iter, - nqp::iterval(nqp::shift($!iter)).antipair, - IterationEnd - ) - } - }.new(self)) - } - multi method roll(::?CLASS:D:) { - nqp::if( - (my $raw := nqp::getattr(self,Map,'$!storage')) && nqp::elems($raw), - nqp::stmts( - (my int $i = nqp::add_i(nqp::elems($raw).rand.floor,1)), - (my $iter := nqp::iterator($raw)), - nqp::while( - nqp::shift($iter) && ($i = nqp::sub_i($i,1)), - nqp::null - ), - nqp::iterval($iter) - ), - Nil - ) - } - multi method roll(::?CLASS:D: Callable:D $calculate) { - self.roll( $calculate(self.elems) ) - } - multi method roll(::?CLASS:D: Whatever $) { self.roll(Inf) } - multi method roll(::?CLASS:D: $count) { - Seq.new(nqp::if( - (my $raw := nqp::getattr(self,Map,'$!storage')) - && nqp::elems($raw) && $count > 0, - class :: does Iterator { - has $!storage; - has $!keys; - has $!count; - - method !SET-SELF(\hash,\count) { - nqp::stmts( - ($!storage := nqp::getattr(hash,Map,'$!storage')), - ($!count = $count), - (my $iter := nqp::iterator($!storage)), - ($!keys := nqp::list_s), - nqp::while( - $iter, - nqp::push_s($!keys,nqp::iterkey_s(nqp::shift($iter))) - ), - self - ) - } - method new(\h,\c) { nqp::create(self)!SET-SELF(h,c) } - method pull-one() { - nqp::if( - $!count, - nqp::stmts( - --$!count, # must be HLL to handle Inf - nqp::atkey( - $!storage, - nqp::atpos_s($!keys,nqp::elems($!keys).rand.floor) - ) - ), - IterationEnd - ) - } - method is-lazy() { $!count == Inf } - }.new(self,$count), - Rakudo::Iterator.Empty - )) - } - multi method perl(::?CLASS:D \SELF:) { - SELF.perlseen('Hash', { - my $TKey-perl := TKey.perl; - my $TValue-perl := TValue.perl; - $TKey-perl eq 'Any' && $TValue-perl eq 'Mu' - ?? ( '$(' x nqp::iscont(SELF) - ~ ':{' ~ SELF.sort.map({.perl}).join(', ') ~ '}' - ~ ')' x nqp::iscont(SELF) - ) - !! '$' x nqp::iscont(SELF) - ~ (self.elems - ?? "(my $TValue-perl %\{$TKey-perl\} = { - self.sort.map({.perl}).join(', ') - })" - !! "(my $TValue-perl %\{$TKey-perl\})" - ) - }) - } - - # gotta force capture keys to strings or binder fails - method Capture() { - nqp::defined(nqp::getattr(self,Map,'$!storage')) - ?? do { - my $cap := nqp::create(Capture); - my $h := nqp::hash(); - for self.kv -> \k, \v { - nqp::bindkey($h, - nqp::unbox_s(nqp::istype(k,Str) ?? k !! k.Str), - v) - } - nqp::bindattr($cap,Capture,'%!hash',$h); - $cap - } - !! nqp::create(Capture) - } - method Map() { self.pairs.Map } - } - - method ^parameterize(Mu:U \hash, Mu:U \t, |c) { - if c.elems == 0 { - my $what := hash.^mixin(TypedHash[t]); - # needs to be done in COMPOSE phaser when that works - $what.^set_name("{hash.^name}[{t.^name}]"); - $what; - } - elsif c.elems == 1 { - my $what := hash.^mixin(TypedHash[t, c[0].WHAT]); - # needs to be done in COMPOSE phaser when that works - $what.^set_name("{hash.^name}[{t.^name},{c[0].^name}]"); - $what; - } - else { - die "Can only type-constrain Hash with [ValueType] or [ValueType,KeyType]"; - } - } -} - - -sub circumfix:<{ }>(*@elems) { my % = @elems } -sub hash(*@a, *%h) { my % = flat @a, %h } - -# XXX parse hangs with ordinary sub declaration -BEGIN my &circumfix:<:{ }> = sub (*@elems) { Hash.^parameterize(Mu,Any).new(@elems) } - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Hash.pm6 rakudo-2018.03/src/core/Hash.pm6 --- rakudo-2018.02.1/src/core/Hash.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/Hash.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,850 @@ +my class X::Invalid::ComputedValue { ... }; + +my class Hash { # declared in BOOTSTRAP + # my class Hash is Map + # has Mu $!descriptor; + + multi method WHICH(Hash:D:) { self.Mu::WHICH } + multi method Hash(Hash:) { + self + } + multi method Map(Hash:U:) { Map } + multi method Map(Hash:D: :$view) { + my $hash := nqp::getattr(self,Map,'$!storage'); + + # empty + if nqp::not_i(nqp::defined($hash)) { + nqp::create(Map) + } + + # view, assuming no change in hash + elsif $view { + nqp::p6bindattrinvres(nqp::create(Map),Map,'$!storage',$hash) + } + + # make cow copy + else { + my $map := nqp::hash; + my \iter := nqp::iterator($hash); + my str $key; + nqp::while( + iter, + nqp::bindkey( + $map, + ($key = nqp::iterkey_s(nqp::shift(iter))), + nqp::decont(nqp::atkey($hash,$key)) + ) + ); + nqp::p6bindattrinvres(nqp::create(Map),Map,'$!storage',$map) + } + } + method clone(Hash:D:) is raw { + nqp::p6bindattrinvres( + nqp::p6bindattrinvres( + nqp::create(self),Map,'$!storage', + nqp::clone(nqp::getattr(self,Map,'$!storage'))), + Hash, '$!descriptor', nqp::isnull($!descriptor) ?? (nqp::null) !! nqp::clone($!descriptor)) + } + + method !AT-KEY-CONTAINER(Str:D \key) is raw { + nqp::p6bindattrinvres( + (my \v := nqp::p6scalarfromdesc($!descriptor)), + Scalar, + '$!whence', + -> { nqp::bindkey( + nqp::if( + nqp::isconcrete(nqp::getattr(self,Map,'$!storage')), + nqp::getattr(self,Map,'$!storage'), + nqp::bindattr(self,Map,'$!storage',nqp::hash) + ),key,v) + } + ) + } + + multi method AT-KEY(Hash:D: Str:D \key) is raw { + nqp::if( + nqp::isconcrete(nqp::getattr(self,Map,'$!storage')), + nqp::ifnull( + nqp::atkey(nqp::getattr(self,Map,'$!storage'),key), + self!AT-KEY-CONTAINER(key) + ), + self!AT-KEY-CONTAINER(key) + ) + } + multi method AT-KEY(Hash:D: \key) is raw { + nqp::if( + nqp::isconcrete(nqp::getattr(self,Map,'$!storage')), + nqp::ifnull( + nqp::atkey(nqp::getattr(self,Map,'$!storage'),key.Str), + self!AT-KEY-CONTAINER(key.Str) + ), + self!AT-KEY-CONTAINER(key.Str) + ) + } + + multi method STORE_AT_KEY(Str:D \key, Mu \x --> Nil) { + nqp::bindkey( + nqp::getattr(self,Map,'$!storage'), + nqp::unbox_s(key), + (nqp::p6scalarfromdesc($!descriptor) = x), + ) + } + multi method STORE_AT_KEY(\key, Mu \x --> Nil) { + nqp::bindkey( + nqp::getattr(self,Map,'$!storage'), + nqp::unbox_s(key.Str), + (nqp::p6scalarfromdesc($!descriptor) = x), + ) + } + + multi method ASSIGN-KEY(Hash:D: Str:D \key, Mu \assignval) is raw { + nqp::if( + nqp::getattr(self,Map,'$!storage').DEFINITE, + (nqp::ifnull( + nqp::atkey( + nqp::getattr(self,Map,'$!storage'), + nqp::unbox_s(key) + ), + nqp::bindkey( + nqp::getattr(self,Map,'$!storage'), + nqp::unbox_s(key), + nqp::p6scalarfromdesc($!descriptor) + ) + ) = assignval), + nqp::bindkey( + nqp::bindattr(self,Map,'$!storage',nqp::hash), + nqp::unbox_s(key), + nqp::p6scalarfromdesc($!descriptor) = assignval + ) + ) + } + multi method ASSIGN-KEY(Hash:D: \key, Mu \assignval) is raw { + nqp::if( + nqp::getattr(self,Map,'$!storage').DEFINITE, + (nqp::ifnull( + nqp::atkey( + nqp::getattr(self,Map,'$!storage'), + nqp::unbox_s(key.Str) + ), + nqp::bindkey( + nqp::getattr(self,Map,'$!storage'), + nqp::unbox_s(key.Str), + nqp::p6scalarfromdesc($!descriptor) + ) + ) = assignval), + nqp::bindkey( + nqp::bindattr(self,Map,'$!storage',nqp::hash), + nqp::unbox_s(key.Str), + nqp::p6scalarfromdesc($!descriptor) = assignval + ) + ) + } + + # for some reason, this can't be turned into a multi without + # making setting compilation get very confused indeed + method BIND-KEY(Hash:D: \key, Mu \bindval) is raw { + nqp::bindattr(self,Map,'$!storage',nqp::hash) + unless nqp::defined(nqp::getattr(self,Map,'$!storage')); + nqp::bindkey(nqp::getattr(self,Map,'$!storage'), + nqp::unbox_s(nqp::istype(key,Str) ?? key !! key.Str), bindval) + } + + multi method DELETE-KEY(Hash:U: --> Nil) { } + multi method DELETE-KEY(Hash:D: Str:D \key) { + nqp::if( + (nqp::getattr(self,Map,'$!storage').DEFINITE + && nqp::existskey(nqp::getattr(self,Map,'$!storage'), + nqp::unbox_s(key))), + nqp::stmts( + (my $value = nqp::atkey(nqp::getattr(self,Map,'$!storage'), + nqp::unbox_s(key))), + nqp::deletekey(nqp::getattr(self,Map,'$!storage'), + nqp::unbox_s(key)), + $value + ), + nqp::p6scalarfromdesc($!descriptor) + ) + } + multi method DELETE-KEY(Hash:D: \key) { + nqp::stmts( + (my str $key = nqp::unbox_s(key.Str)), + nqp::if( + (nqp::getattr(self,Map,'$!storage').DEFINITE + && nqp::existskey(nqp::getattr(self,Map,'$!storage'),$key)), + nqp::stmts( + (my $value = nqp::atkey(nqp::getattr(self,Map,'$!storage'),$key)), + nqp::deletekey(nqp::getattr(self,Map,'$!storage'),$key), + $value + ), + nqp::p6scalarfromdesc($!descriptor) + ) + ) + } + + multi method perl(Hash:D \SELF:) { + SELF.perlseen(self.^name, { + '$' x nqp::iscont(SELF) # self is always deconted + ~ '{' ~ self.sort.map({.perl}).join(', ') ~ '}' + }) + } + + multi method gist(Hash:D:) { + self.gistseen(self.^name, { + '{' ~ + self.sort.map({ + state $i = 0; + ++$i == 101 ?? '...' + !! $i == 102 ?? last() + !! .gist + }).join(', ') + ~ '}' + }) + } + + multi method DUMP(Hash:D: :$indent-step = 4, :%ctx) { + nqp::if( + %ctx, + self.DUMP-OBJECT-ATTRS( + nqp::list( + '$!descriptor', + $!descriptor, + '$!storage', + nqp::getattr(nqp::decont(self),Map,'$!storage') + ), + :$indent-step, + :%ctx + ), + DUMP(self, :$indent-step) + ) + } + + # introspection + method name() { + nqp::isnull($!descriptor) ?? Nil !! $!descriptor.name + } + method keyof() { + Str(Any) + } + method of() { + nqp::isnull($!descriptor) ?? Mu !! $!descriptor.of + } + method default() { + nqp::isnull($!descriptor) ?? Any !! $!descriptor.default + } + method dynamic() { + nqp::isnull($!descriptor) ?? False !! nqp::p6bool($!descriptor.dynamic) + } + + method push(+values) { + fail X::Cannot::Lazy.new(:action, :what(self.^name)) + if values.is-lazy; + + my $previous; + my int $has_previous = 0; + + nqp::if( + $has_previous, + nqp::stmts( + self!_push_construct($previous,$_), + ($has_previous = 0) + ), + nqp::if( + nqp::istype($_,Pair), + self!_push_construct(.key,.value), + nqp::stmts( + ($previous := $_), + ($has_previous = 1) + ) + ) + ) for values; + + warn "Trailing item in {self.^name}.push" if $has_previous; + self + } + + method append(+values) { + fail X::Cannot::Lazy.new(:action, :what(self.^name)) + if values.is-lazy; + + my $previous; + my int $has_previous = 0; + + nqp::if( + $has_previous, + nqp::stmts( + self!_append_construct($previous,$_), + ($has_previous = 0) + ), + nqp::if( + nqp::istype($_,Pair), + self!_append_construct(.key,.value), + nqp::stmts( + ($previous := $_), + ($has_previous = 1) + ) + ) + ) for values; + + warn "Trailing item in {self.^name}.append" if $has_previous; + self + } + + proto method classify-list(|) {*} + multi method classify-list( &test, \list, :&as ) { + fail X::Cannot::Lazy.new(:action) if list.is-lazy; + my \iter = (nqp::istype(list, Iterable) ?? list !! list.list).iterator; + my $value := iter.pull-one; + unless $value =:= IterationEnd { + my $tested := test($value); + + # multi-level classify + if nqp::istype($tested, Iterable) { + my $els = $tested.elems; + loop { + my @keys = @$tested; + @keys == $els or X::Invalid::ComputedValue.new( + :name, + :method, + :value('an item with different number of elements ' + ~ 'in it than previous items'), + :reason('all values need to have the same number ' + ~ 'of elements. Mixed-level classification is ' + ~ 'not supported.'), + ).throw; + my $last := @keys.pop; + my $hash = self; + $hash = $hash{$_} //= self.new for @keys; + $hash{$last}.push(&as ?? as($value) !! $value); + last if ($value := iter.pull-one) =:= IterationEnd; + $tested := test($value); + }; + } + # just a simple classify + else { + loop { + self{$tested}.push(&as ?? as($value) !! $value); + last if ($value := iter.pull-one) =:= IterationEnd; + nqp::istype(($tested := test($value)), Iterable) + and X::Invalid::ComputedValue.new( + :name, + :method, + :value('an item with different number of elements ' + ~ 'in it than previous items'), + :reason('all values need to have the same number ' + ~ 'of elements. Mixed-level classification is ' + ~ 'not supported.'), + ).throw; + }; + } + } + self; + } + multi method classify-list( %test, |c ) { + self.classify-list( { %test{$^a} }, |c ); + } + multi method classify-list( @test, |c ) { + self.classify-list( { @test[$^a] }, |c ); + } + multi method classify-list(&test, **@list, |c) { + self.classify-list(&test, @list, |c); + } + + proto method categorize-list(|) {*} + multi method categorize-list( &test, \list, :&as ) { + fail X::Cannot::Lazy.new(:action) if list.is-lazy; + my \iter = (nqp::istype(list, Iterable) ?? list !! list.list).iterator; + my $value := iter.pull-one; + unless $value =:= IterationEnd { + my $tested := test($value); + + # multi-level categorize + if nqp::istype($tested[0],Iterable) { + my $els = $tested[0].elems; + loop { + for $tested.cache -> $cat { + my @keys = @$cat or next; + my $last := @keys.pop; + my $hash = self; + $hash = $hash{$_} //= self.new for @keys; + $hash{$last}.push(&as ?? as($value) !! $value); + } + + last if ($value := iter.pull-one) =:= IterationEnd; + $tested := test($value); + + nqp::istype($tested[0],Iterable) + and $els == $tested[0] + or X::Invalid::ComputedValue.new( + :name, + :method, + :value('an item with different number of elements ' + ~ 'in it than previous items'), + :reason('all values need to have the same number ' + ~ 'of elements. Mixed-level classification is ' + ~ 'not supported.'), + ).throw; + } + } + # simple categorize + else { + loop { + self{$_}.push(&as ?? as($value) !! $value) + for @$tested; + last if ($value := iter.pull-one) =:= IterationEnd; + nqp::istype(($tested := test($value))[0], Iterable) + and X::Invalid::ComputedValue.new( + :name, + :method, + :value('an item with different number of elements ' + ~ 'in it than previous items'), + :reason('all values need to have the same number ' + ~ 'of elements. Mixed-level classification is ' + ~ 'not supported.'), + ).throw; + }; + } + } + self; + } + multi method categorize-list( %test, |c ) { + self.categorize-list( { %test{$^a} }, |c ); + } + multi method categorize-list( @test, |c ) { + self.categorize-list( { @test[$^a] }, |c ); + } + multi method categorize-list( &test, **@list, |c ) { + self.categorize-list( &test, @list, |c ); + } + + # push a value onto a hash slot, constructing an array if necessary + method !_push_construct(Mu $key, Mu \value --> Nil) { + self.EXISTS-KEY($key) + ?? self.AT-KEY($key).^isa(Array) + ?? self.AT-KEY($key).push(value) + !! self.ASSIGN-KEY($key,[self.AT-KEY($key),value]) + !! self.ASSIGN-KEY($key,value) + } + + # append values into a hash slot, constructing an array if necessary + method !_append_construct(Mu $key, Mu \value --> Nil) { + self.EXISTS-KEY($key) + ?? self.AT-KEY($key).^isa(Array) + ?? self.AT-KEY($key).append(|value) + !! self.ASSIGN-KEY($key,[|self.AT-KEY($key),|value]) + !! self.ASSIGN-KEY($key,value) + } + + my role TypedHash[::TValue] does Associative[TValue] { + # These ASSIGN-KEY candidates are only needed because of: + # my Int %h; try %h = "foo"; dd %h + # leaving an uninitialized Int for key in the hash. If + # we could live with that, then these candidates can be + # removed. However, there are spectest covering this + # eventuality, so to appease roast, we need these. + multi method ASSIGN-KEY(::?CLASS:D: Str:D \key, Mu \assignval) is raw { + nqp::if( + nqp::getattr(self,Map,'$!storage').DEFINITE, + nqp::if( + nqp::existskey( + nqp::getattr(self,Map,'$!storage'), + nqp::unbox_s(key) + ), + (nqp::atkey( + nqp::getattr(self,Map,'$!storage'), + nqp::unbox_s(key) + ) = assignval), + nqp::bindkey( + nqp::getattr(self,Map,'$!storage'), + nqp::unbox_s(key), + nqp::p6scalarfromdesc( + nqp::getattr(self,Hash,'$!descriptor')) = assignval + ) + ), + nqp::bindkey( + nqp::bindattr(self,Map,'$!storage',nqp::hash), + nqp::unbox_s(key), + nqp::p6scalarfromdesc( + nqp::getattr(self,Hash,'$!descriptor')) = assignval + ) + ) + } + multi method ASSIGN-KEY(::?CLASS:D: \key, Mu \assignval) is raw { + nqp::stmts( + (my str $key = nqp::unbox_s(key.Str)), + nqp::if( + nqp::getattr(self,Map,'$!storage').DEFINITE, + nqp::if( + nqp::existskey( + nqp::getattr(self,Map,'$!storage'), + $key + ), + (nqp::atkey( + nqp::getattr(self,Map,'$!storage'), + $key + ) = assignval), + nqp::bindkey( + nqp::getattr(self,Map,'$!storage'), + nqp::unbox_s(key.Str), + nqp::p6scalarfromdesc( + nqp::getattr(self,Hash,'$!descriptor')) = assignval + ) + ), + nqp::bindkey( + nqp::bindattr(self,Map,'$!storage',nqp::hash), + $key, + nqp::p6scalarfromdesc( + nqp::getattr(self,Hash,'$!descriptor')) = assignval + ) + ) + ) + } + multi method perl(::?CLASS:D \SELF:) { + SELF.perlseen('Hash', { + '$' x nqp::iscont(SELF) # self is always deconted + ~ (self.elems + ?? "(my {TValue.perl} % = { + self.sort.map({.perl}).join(', ') + })" + !! "(my {TValue.perl} %)" + ) + }) + } + } + my role TypedHash[::TValue, ::TKey] does Associative[TValue] { + method keyof () { TKey } + method AT-KEY(::?CLASS:D: TKey \key) is raw { + nqp::if( + nqp::getattr(self,Map,'$!storage').DEFINITE, + nqp::if( + nqp::existskey(nqp::getattr(self,Map,'$!storage'), + (my str $which = nqp::unbox_s(key.WHICH))), + nqp::getattr( + nqp::atkey(nqp::getattr(self,Map,'$!storage'),$which), + Pair,'$!value'), + nqp::p6bindattrinvres( + (my \v := nqp::p6scalarfromdesc( + nqp::getattr(self,Hash,'$!descriptor'))), + Scalar, + '$!whence', + -> { nqp::bindkey(nqp::getattr(self,Map,'$!storage'), + $which,Pair.new(key,v)); v } + ) + ), + nqp::p6bindattrinvres( + (my \vv := nqp::p6scalarfromdesc( + nqp::getattr(self,Hash,'$!descriptor'))), + Scalar, + '$!whence', + -> { nqp::bindkey( + nqp::if( + nqp::getattr(self,Map,'$!storage').DEFINITE, + nqp::getattr(self,Map,'$!storage'), + nqp::bindattr(self,Map,'$!storage',nqp::hash) + ), + nqp::unbox_s(key.WHICH), Pair.new(key,vv)); vv } + ) + ) + } + + method STORE_AT_KEY(TKey \key, TValue \x --> Nil) { + nqp::bindkey( + nqp::getattr(self,Map,'$!storage'), + nqp::unbox_s(key.WHICH), + Pair.new( + key, + nqp::p6scalarfromdesc(nqp::getattr(self,Hash,'$!descriptor')) + = x + ) + ) + } + + method ASSIGN-KEY(::?CLASS:D: TKey \key, TValue \assignval) is raw { + nqp::if( + nqp::getattr(self,Map,'$!storage').DEFINITE, + nqp::if( + nqp::existskey(nqp::getattr(self,Map,'$!storage'), + my str $which = nqp::unbox_s(key.WHICH)), + (nqp::getattr( + nqp::atkey(nqp::getattr(self,Map,'$!storage'),$which), + Pair,'$!value') = assignval), + nqp::getattr( + (nqp::bindkey(nqp::getattr(self,Map,'$!storage'),$which, + Pair.new(key,nqp::p6scalarfromdesc( + nqp::getattr(self,Hash,'$!descriptor')) = assignval))), + Pair,'$!value') + ), + nqp::getattr( + (nqp::bindkey(nqp::bindattr(self,Map,'$!storage',nqp::hash), + nqp::unbox_s(key.WHICH), + Pair.new(key,nqp::p6scalarfromdesc( + nqp::getattr(self,Hash,'$!descriptor')) = assignval))), + Pair,'$!value') + ) + } + + method BIND-KEY(TKey \key, TValue \bindval) is raw { + nqp::getattr( + nqp::if( + nqp::getattr(self,Map,'$!storage').DEFINITE, + nqp::bindkey(nqp::getattr(self,Map,'$!storage'), + nqp::unbox_s(key.WHICH), + Pair.new(key,bindval)), + nqp::bindkey(nqp::bindattr(self,Map,'$!storage',nqp::hash), + nqp::unbox_s(key.WHICH), + Pair.new(key,bindval)) + ), + Pair,'$!value' + ) + } + + method EXISTS-KEY(TKey \key) { + nqp::p6bool( + nqp::defined(nqp::getattr(self,Map,'$!storage')) + && nqp::existskey(nqp::getattr(self,Map,'$!storage'),key.WHICH) + ) + } + + method DELETE-KEY(TKey \key) { + nqp::if( + (nqp::getattr(self,Map,'$!storage').DEFINITE + && nqp::existskey(nqp::getattr(self,Map,'$!storage'), + (my str $which = key.WHICH))), + nqp::stmts( + (my TValue $value = + nqp::getattr( + nqp::atkey(nqp::getattr(self,Map,'$!storage'),$which), + Pair,'$!value')), + nqp::deletekey(nqp::getattr(self,Map,'$!storage'),$which), + $value + ), + TValue + ) + } + + method FLATTENABLE_HASH() { + nqp::stmts( + (my $flattened := nqp::hash), + nqp::if( + (my $raw := nqp::getattr(self,Map,'$!storage')) + && (my $iter := nqp::iterator($raw)), + nqp::while( + $iter, + nqp::bindkey( + $flattened, + nqp::if( + nqp::istype( + (my $key := nqp::getattr( + nqp::iterval(nqp::shift($iter)), + Pair, + '$!key' + )), + Str, + ), + $key, + $key.Str + ), + nqp::getattr(nqp::iterval($iter),Pair,'$!value') + ) + ) + ), + $flattened + ) + } + + method IterationBuffer() { + nqp::stmts( + (my $buffer := nqp::create(IterationBuffer)), + nqp::if( + nqp::defined( + nqp::getattr(self,Map,'$!storage') + ) && nqp::elems( + nqp::getattr(self,Map,'$!storage') + ), + nqp::stmts( + (my $iterator := nqp::iterator( + nqp::getattr(self,Map,'$!storage') + )), + nqp::setelems($buffer,nqp::elems( + nqp::getattr(self,Map,'$!storage') + )), + (my int $i = -1), + nqp::while( + $iterator, + nqp::bindpos($buffer,($i = nqp::add_i($i,1)), + nqp::iterval(nqp::shift($iterator))) + ) + ) + ), + $buffer + ) + } + + method keys() { + Seq.new(class :: does Rakudo::Iterator::Mappy { + method pull-one() { + nqp::if( + $!iter, + nqp::getattr(nqp::iterval(nqp::shift($!iter)), + Pair,'$!key'), + IterationEnd + ) + } + }.new(self)) + } + method values() { + Seq.new(class :: does Rakudo::Iterator::Mappy { + method pull-one() { + nqp::if( + $!iter, + nqp::getattr(nqp::iterval(nqp::shift($!iter)), + Pair,'$!value'), + IterationEnd + ) + } + }.new(self)) + } + method kv() { + Seq.new(Rakudo::Iterator.Mappy-kv-from-pairs(self)) + } + method iterator() { Rakudo::Iterator.Mappy-values(self) } + method antipairs() { + Seq.new(class :: does Rakudo::Iterator::Mappy { + method pull-one() { + nqp::if( + $!iter, + nqp::iterval(nqp::shift($!iter)).antipair, + IterationEnd + ) + } + }.new(self)) + } + multi method roll(::?CLASS:D:) { + nqp::if( + (my $raw := nqp::getattr(self,Map,'$!storage')) && nqp::elems($raw), + nqp::stmts( + (my int $i = nqp::add_i(nqp::elems($raw).rand.floor,1)), + (my $iter := nqp::iterator($raw)), + nqp::while( + nqp::shift($iter) && ($i = nqp::sub_i($i,1)), + nqp::null + ), + nqp::iterval($iter) + ), + Nil + ) + } + multi method roll(::?CLASS:D: Callable:D $calculate) { + self.roll( $calculate(self.elems) ) + } + multi method roll(::?CLASS:D: Whatever $) { self.roll(Inf) } + multi method roll(::?CLASS:D: $count) { + Seq.new(nqp::if( + (my $raw := nqp::getattr(self,Map,'$!storage')) + && nqp::elems($raw) && $count > 0, + class :: does Iterator { + has $!storage; + has $!keys; + has $!count; + + method !SET-SELF(\hash,\count) { + nqp::stmts( + ($!storage := nqp::getattr(hash,Map,'$!storage')), + ($!count = $count), + (my $iter := nqp::iterator($!storage)), + ($!keys := nqp::list_s), + nqp::while( + $iter, + nqp::push_s($!keys,nqp::iterkey_s(nqp::shift($iter))) + ), + self + ) + } + method new(\h,\c) { nqp::create(self)!SET-SELF(h,c) } + method pull-one() { + nqp::if( + $!count, + nqp::stmts( + --$!count, # must be HLL to handle Inf + nqp::atkey( + $!storage, + nqp::atpos_s($!keys,nqp::elems($!keys).rand.floor) + ) + ), + IterationEnd + ) + } + method is-lazy() { $!count == Inf } + }.new(self,$count), + Rakudo::Iterator.Empty + )) + } + multi method perl(::?CLASS:D \SELF:) { + SELF.perlseen('Hash', { + my $TKey-perl := TKey.perl; + my $TValue-perl := TValue.perl; + $TKey-perl eq 'Any' && $TValue-perl eq 'Mu' + ?? ( '$(' x nqp::iscont(SELF) + ~ ':{' ~ SELF.sort.map({.perl}).join(', ') ~ '}' + ~ ')' x nqp::iscont(SELF) + ) + !! '$' x nqp::iscont(SELF) + ~ (self.elems + ?? "(my $TValue-perl %\{$TKey-perl\} = { + self.sort.map({.perl}).join(', ') + })" + !! "(my $TValue-perl %\{$TKey-perl\})" + ) + }) + } + + # gotta force capture keys to strings or binder fails + method Capture() { + nqp::defined(nqp::getattr(self,Map,'$!storage')) + ?? do { + my $cap := nqp::create(Capture); + my $h := nqp::hash(); + for self.kv -> \k, \v { + nqp::bindkey($h, + nqp::unbox_s(nqp::istype(k,Str) ?? k !! k.Str), + v) + } + nqp::bindattr($cap,Capture,'%!hash',$h); + $cap + } + !! nqp::create(Capture) + } + method Map() { self.pairs.Map } + } + + method ^parameterize(Mu:U \hash, Mu:U \t, |c) { + if c.elems == 0 { + my $what := hash.^mixin(TypedHash[t]); + # needs to be done in COMPOSE phaser when that works + $what.^set_name("{hash.^name}[{t.^name}]"); + $what; + } + elsif c.elems == 1 { + my $what := hash.^mixin(TypedHash[t, c[0].WHAT]); + # needs to be done in COMPOSE phaser when that works + $what.^set_name("{hash.^name}[{t.^name},{c[0].^name}]"); + $what; + } + else { + die "Can only type-constrain Hash with [ValueType] or [ValueType,KeyType]"; + } + } +} + +proto sub circumfix:<{ }>(|) {*} +multi sub circumfix:<{ }>(*@elems) { my % = @elems } + +# XXX parse dies with 'don't change grammar in the setting, please!' +# with ordinary sub declaration +#sub circumfix:<:{ }>(*@elems) { Hash.^parameterize(Mu,Any).new(@elems) } +BEGIN my &circumfix:<:{ }> = sub (*@e) { Hash.^parameterize(Mu,Any).new(@e) } + +proto sub hash(|) {*} +multi sub hash(*%h) { %h } +multi sub hash(*@a, *%h) { my % = flat @a, %h } + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/hash_slice.pm rakudo-2018.03/src/core/hash_slice.pm --- rakudo-2018.02.1/src/core/hash_slice.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/hash_slice.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,238 +0,0 @@ -# all sub postcircumfix {} candidates here please - -proto sub postcircumfix:<{ }>(|) is nodal {*} - -# %h -multi sub postcircumfix:<{ }>( \SELF, \key ) is raw { - SELF.AT-KEY(key); -} -multi sub postcircumfix:<{ }>(\SELF, \key, Mu \ASSIGN) is raw { - SELF.ASSIGN-KEY(key, ASSIGN); -} -multi sub postcircumfix:<{ }>(\SELF, \key, Mu :$BIND! is raw) is raw { - SELF.BIND-KEY(key, $BIND); -} -multi sub postcircumfix:<{ }>( \SELF, \key, :$delete!, *%other ) is raw { - nqp::if( - $delete && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))), - SELF.DELETE-KEY(key), - SLICE_ONE_HASH( SELF, key, 'delete', $delete, %other ) - ) -} -multi sub postcircumfix:<{ }>( \SELF, \key, :$exists!, *%other ) is raw { - nqp::if( - $exists && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))), - SELF.EXISTS-KEY(key), - SLICE_ONE_HASH( SELF, key, 'exists', $exists, %other ) - ) -} -multi sub postcircumfix:<{ }>( \SELF, \key, :$kv!, *%other ) is raw { - $kv && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? (SELF.EXISTS-KEY(key) ?? (key,SELF.AT-KEY(key)) !! ()) - !! SLICE_ONE_HASH( SELF, key, 'kv', $kv, %other ); -} -multi sub postcircumfix:<{ }>( \SELF, \key, :$p!, *%other ) is raw { - $p && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? (SELF.EXISTS-KEY(key) ?? Pair.new(key,SELF.AT-KEY(key)) !! ()) - !! SLICE_ONE_HASH( SELF, key, 'p', $p, %other ); -} -multi sub postcircumfix:<{ }>( \SELF, \key, :$k!, *%other ) is raw { - $k && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? (SELF.EXISTS-KEY(key) ?? key !! ()) - !! SLICE_ONE_HASH( SELF, key, 'k', $k, %other ); -} -multi sub postcircumfix:<{ }>( \SELF, \key, :$v!, *%other ) is raw { - $v && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) - ?? (SELF.EXISTS-KEY(key) ?? nqp::decont(SELF.AT-KEY(key)) !! ()) - !! SLICE_ONE_HASH( SELF, key, 'v', $v, %other ); -} - -# %h -multi sub postcircumfix:<{ }>( \SELF, Iterable \key ) is raw { - nqp::iscont(key) - ?? SELF.AT-KEY(key) - !! key.flatmap({ SELF{$_} }).eager.list; -} -multi sub postcircumfix:<{ }>(\SELF, Iterable \key, Mu \ASSIGN) is raw { - nqp::iscont(key) - ?? SELF.ASSIGN-KEY(key, ASSIGN) - !! (key.flatmap({ SELF{$_} }).eager.list = ASSIGN) -} -multi sub postcircumfix:<{ }>(\SELF, Iterable \key, :$BIND!) is raw { - X::Bind::Slice.new(type => SELF.WHAT).throw; -} -multi sub postcircumfix:<{ }>(\SELF,Iterable \key, :$delete!,*%other) is raw { - nqp::iscont(key) - ?? SLICE_ONE_HASH( SELF, key, 'delete', $delete, %other ) - !! SLICE_MORE_HASH( SELF, key, 'delete', $delete, %other ) -} -multi sub postcircumfix:<{ }>(\SELF,Iterable \key, :$exists!,*%other) is raw { - nqp::iscont(key) - ?? SLICE_ONE_HASH( SELF, key, 'exists', $exists, %other ) - !! SLICE_MORE_HASH( SELF, key, 'exists', $exists, %other ) -} -multi sub postcircumfix:<{ }>(\SELF, Iterable \key, :$kv!, *%other) is raw { - nqp::iscont(key) - ?? SLICE_ONE_HASH( SELF, key, 'kv', $kv, %other ) - !! SLICE_MORE_HASH( SELF, key, 'kv', $kv, %other ) -} -multi sub postcircumfix:<{ }>(\SELF, Iterable \key, :$p!, *%other) is raw { - nqp::iscont(key) - ?? SLICE_ONE_HASH( SELF, key, 'p', $p, %other ) - !! SLICE_MORE_HASH( SELF, key, 'p', $p, %other ) -} -multi sub postcircumfix:<{ }>(\SELF, Iterable \key, :$k!, *%other) is raw { - nqp::iscont(key) - ?? SLICE_ONE_HASH( SELF, key, 'k', $k, %other ) - !! SLICE_MORE_HASH( SELF, key, 'k', $k, %other ) -} -multi sub postcircumfix:<{ }>(\SELF, Iterable \key, :$v!, *%other) is raw { - nqp::iscont(key) - ?? SLICE_ONE_HASH( SELF, key, 'v', $v, %other ) - !! SLICE_MORE_HASH( SELF, key, 'v', $v, %other ) -} - -# %h{*} -multi sub postcircumfix:<{ }>( \SELF, Whatever ) is raw { - SELF{SELF.keys.list}; -} -multi sub postcircumfix:<{ }>(\SELF, Whatever, Mu \ASSIGN) is raw { - die "Cannot assign to *, as the order of keys is non-deterministic"; -} -multi sub postcircumfix:<{ }>(\SELF, Whatever, :$BIND!) is raw { - X::Bind::Slice.new(type => SELF.WHAT).throw; -} -multi sub postcircumfix:<{ }>(\SELF, Whatever, :$delete!, *%other) is raw { - SLICE_MORE_HASH( SELF, SELF.keys.list, 'delete', $delete, %other ); -} -multi sub postcircumfix:<{ }>(\SELF, Whatever, :$exists!, *%other) is raw { - SLICE_MORE_HASH( SELF, SELF.keys.list, 'exists', $exists, %other ); -} -multi sub postcircumfix:<{ }>(\SELF, Whatever, :$kv!, *%other) is raw { - SLICE_MORE_HASH( SELF, SELF.keys.list, 'kv', $kv, %other ); -} -multi sub postcircumfix:<{ }>(\SELF, Whatever, :$p!, *%other) is raw { - SLICE_MORE_HASH( SELF, SELF.keys.list, 'p', $p, %other ); -} -multi sub postcircumfix:<{ }>(\SELF, Whatever, :$k!, *%other) is raw { - SLICE_MORE_HASH( SELF, SELF.keys.list, 'k', $k, %other ); -} -multi sub postcircumfix:<{ }>(\SELF, Whatever, :$p!, *%other) is raw { - SLICE_MORE_HASH( SELF, SELF.keys.list, 'p', $p, %other ); -} -multi sub postcircumfix:<{ }>(\SELF, Whatever, :$v!, *%other) is raw { - nqp::elems(nqp::getattr(%other,Map,'$!storage')) - ?? SLICE_MORE_HASH( SELF, SELF.keys.list, 'v', $v, %other ) - !! SELF{SELF.keys.list}; -} - -# %h{} -multi sub postcircumfix:<{ }>(\SELF, :$BIND!) is raw { - X::Bind::ZenSlice.new(type => SELF.WHAT).throw; -} -multi sub postcircumfix:<{ }>(\SELF, :$delete!, *%other) is raw { - SLICE_MORE_HASH( SELF, SELF.keys.list, 'delete', $delete, %other ); -} -multi sub postcircumfix:<{ }>(\SELF, :$exists!, *%other) is raw { - SLICE_MORE_HASH( SELF, SELF.keys.list, 'exists', $exists, %other ); -} -multi sub postcircumfix:<{ }>(\SELF, :$kv!, *%other) is raw { - SLICE_MORE_HASH( SELF, SELF.keys.list, 'kv', $kv, %other ); -} -multi sub postcircumfix:<{ }>(\SELF, :$p!, *%other) is raw { - SLICE_MORE_HASH( SELF, SELF.keys.list, 'p', $p, %other ); -} -multi sub postcircumfix:<{ }>(\SELF, :$k!, *%other) is raw { - SLICE_MORE_HASH( SELF, SELF.keys.list, 'k', $k, %other ); -} -multi sub postcircumfix:<{ }>(\SELF, :$p!, *%other) is raw { - SLICE_MORE_HASH( SELF, SELF.keys.list, 'p', $p, %other ); -} -multi sub postcircumfix:<{ }>(\SELF, :$v!, *%other) is raw { - nqp::elems(nqp::getattr(%other,Map,'$!storage')) - ?? SLICE_MORE_HASH( SELF, SELF.keys.list, 'v', $v, %other ) - !! SELF{SELF.keys.list}; -} -multi sub postcircumfix:<{ }>( \SELF, *%other ) is raw { - SELF.ZEN-KEY(|%other); -} - - -proto sub postcircumfix:<{; }>(|) is nodal {*} - -sub MD-HASH-SLICE-ONE-POSITION(\SELF, \indices, \idx, int $dim, \target) { - my int $next-dim = $dim + 1; - if $next-dim < indices.elems { - if nqp::istype(idx, Iterable) && !nqp::iscont(idx) { - for idx { - MD-HASH-SLICE-ONE-POSITION(SELF, indices, $_, $dim, target) - } - } - elsif nqp::istype(idx, Str) { - MD-HASH-SLICE-ONE-POSITION(SELF.AT-KEY(idx), indices, indices.AT-POS($next-dim), $next-dim, target) - } - elsif nqp::istype(idx, Whatever) { - for SELF.keys { - MD-HASH-SLICE-ONE-POSITION(SELF.AT-KEY($_), indices, indices.AT-POS($next-dim), $next-dim, target) - } - } - else { - MD-HASH-SLICE-ONE-POSITION(SELF.AT-KEY(idx), indices, indices.AT-POS($next-dim), $next-dim, target) - } - } - else { - if nqp::istype(idx, Iterable) && !nqp::iscont(idx) { - for idx { - MD-HASH-SLICE-ONE-POSITION(SELF, indices, $_, $dim, target) - } - } - elsif nqp::istype(idx, Str) { - nqp::push(target, SELF.AT-KEY(idx)) - } - elsif nqp::istype(idx, Whatever) { - for SELF.keys { - nqp::push(target, SELF.AT-KEY($_)) - } - } - else { - nqp::push(target, SELF.AT-KEY(idx)) - } - } -} - -multi sub postcircumfix:<{; }>(\SELF, @indices) { - my \target = IterationBuffer.new; - MD-HASH-SLICE-ONE-POSITION(SELF, @indices, @indices.AT-POS(0), 0, target); - nqp::p6bindattrinvres(nqp::create(List), List, '$!reified', target) -} - -multi sub postcircumfix:<{; }>(\SELF, @indices, :$exists!) { - sub recurse-at-key(\SELF, \indices) { - my \idx := indices[0]; - my \exists := SELF.EXISTS-KEY(idx); - nqp::if( - nqp::istype(idx, Iterable), - idx.map({ |recurse-at-key(SELF, ($_, |indices.skip.cache)) }).List, - nqp::if( - nqp::iseq_I(indices.elems, 1), - exists, - nqp::if( - exists, - recurse-at-key(SELF{idx}, indices.skip.cache), - nqp::stmts( - (my \times := indices.map({ .elems }).reduce(&[*])), - nqp::if( - nqp::iseq_I(times, 1), - False, - (False xx times).List - ) - ).head - ) - ) - ); - } - - recurse-at-key(SELF, @indices) -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/hash_slice.pm6 rakudo-2018.03/src/core/hash_slice.pm6 --- rakudo-2018.02.1/src/core/hash_slice.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/hash_slice.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,238 @@ +# all sub postcircumfix {} candidates here please + +proto sub postcircumfix:<{ }>(|) is nodal {*} + +# %h +multi sub postcircumfix:<{ }>( \SELF, \key ) is raw { + SELF.AT-KEY(key); +} +multi sub postcircumfix:<{ }>(\SELF, \key, Mu \ASSIGN) is raw { + SELF.ASSIGN-KEY(key, ASSIGN); +} +multi sub postcircumfix:<{ }>(\SELF, \key, Mu :$BIND! is raw) is raw { + SELF.BIND-KEY(key, $BIND); +} +multi sub postcircumfix:<{ }>( \SELF, \key, :$delete!, *%other ) is raw { + nqp::if( + $delete && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))), + SELF.DELETE-KEY(key), + SLICE_ONE_HASH( SELF, key, 'delete', $delete, %other ) + ) +} +multi sub postcircumfix:<{ }>( \SELF, \key, :$exists!, *%other ) is raw { + nqp::if( + $exists && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))), + SELF.EXISTS-KEY(key), + SLICE_ONE_HASH( SELF, key, 'exists', $exists, %other ) + ) +} +multi sub postcircumfix:<{ }>( \SELF, \key, :$kv!, *%other ) is raw { + $kv && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? (SELF.EXISTS-KEY(key) ?? (key,SELF.AT-KEY(key)) !! ()) + !! SLICE_ONE_HASH( SELF, key, 'kv', $kv, %other ); +} +multi sub postcircumfix:<{ }>( \SELF, \key, :$p!, *%other ) is raw { + $p && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? (SELF.EXISTS-KEY(key) ?? Pair.new(key,SELF.AT-KEY(key)) !! ()) + !! SLICE_ONE_HASH( SELF, key, 'p', $p, %other ); +} +multi sub postcircumfix:<{ }>( \SELF, \key, :$k!, *%other ) is raw { + $k && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? (SELF.EXISTS-KEY(key) ?? key !! ()) + !! SLICE_ONE_HASH( SELF, key, 'k', $k, %other ); +} +multi sub postcircumfix:<{ }>( \SELF, \key, :$v!, *%other ) is raw { + $v && nqp::not_i(nqp::elems(nqp::getattr(%other,Map,'$!storage'))) + ?? (SELF.EXISTS-KEY(key) ?? nqp::decont(SELF.AT-KEY(key)) !! ()) + !! SLICE_ONE_HASH( SELF, key, 'v', $v, %other ); +} + +# %h +multi sub postcircumfix:<{ }>( \SELF, Iterable \key ) is raw { + nqp::iscont(key) + ?? SELF.AT-KEY(key) + !! key.flatmap({ SELF{$_} }).eager.list; +} +multi sub postcircumfix:<{ }>(\SELF, Iterable \key, Mu \ASSIGN) is raw { + nqp::iscont(key) + ?? SELF.ASSIGN-KEY(key, ASSIGN) + !! (key.flatmap({ SELF{$_} }).eager.list = ASSIGN) +} +multi sub postcircumfix:<{ }>(\SELF, Iterable \key, :$BIND!) is raw { + X::Bind::Slice.new(type => SELF.WHAT).throw; +} +multi sub postcircumfix:<{ }>(\SELF,Iterable \key, :$delete!,*%other) is raw { + nqp::iscont(key) + ?? SLICE_ONE_HASH( SELF, key, 'delete', $delete, %other ) + !! SLICE_MORE_HASH( SELF, key, 'delete', $delete, %other ) +} +multi sub postcircumfix:<{ }>(\SELF,Iterable \key, :$exists!,*%other) is raw { + nqp::iscont(key) + ?? SLICE_ONE_HASH( SELF, key, 'exists', $exists, %other ) + !! SLICE_MORE_HASH( SELF, key, 'exists', $exists, %other ) +} +multi sub postcircumfix:<{ }>(\SELF, Iterable \key, :$kv!, *%other) is raw { + nqp::iscont(key) + ?? SLICE_ONE_HASH( SELF, key, 'kv', $kv, %other ) + !! SLICE_MORE_HASH( SELF, key, 'kv', $kv, %other ) +} +multi sub postcircumfix:<{ }>(\SELF, Iterable \key, :$p!, *%other) is raw { + nqp::iscont(key) + ?? SLICE_ONE_HASH( SELF, key, 'p', $p, %other ) + !! SLICE_MORE_HASH( SELF, key, 'p', $p, %other ) +} +multi sub postcircumfix:<{ }>(\SELF, Iterable \key, :$k!, *%other) is raw { + nqp::iscont(key) + ?? SLICE_ONE_HASH( SELF, key, 'k', $k, %other ) + !! SLICE_MORE_HASH( SELF, key, 'k', $k, %other ) +} +multi sub postcircumfix:<{ }>(\SELF, Iterable \key, :$v!, *%other) is raw { + nqp::iscont(key) + ?? SLICE_ONE_HASH( SELF, key, 'v', $v, %other ) + !! SLICE_MORE_HASH( SELF, key, 'v', $v, %other ) +} + +# %h{*} +multi sub postcircumfix:<{ }>( \SELF, Whatever ) is raw { + SELF{SELF.keys.list}; +} +multi sub postcircumfix:<{ }>(\SELF, Whatever, Mu \ASSIGN) is raw { + die "Cannot assign to *, as the order of keys is non-deterministic"; +} +multi sub postcircumfix:<{ }>(\SELF, Whatever, :$BIND!) is raw { + X::Bind::Slice.new(type => SELF.WHAT).throw; +} +multi sub postcircumfix:<{ }>(\SELF, Whatever, :$delete!, *%other) is raw { + SLICE_MORE_HASH( SELF, SELF.keys.list, 'delete', $delete, %other ); +} +multi sub postcircumfix:<{ }>(\SELF, Whatever, :$exists!, *%other) is raw { + SLICE_MORE_HASH( SELF, SELF.keys.list, 'exists', $exists, %other ); +} +multi sub postcircumfix:<{ }>(\SELF, Whatever, :$kv!, *%other) is raw { + SLICE_MORE_HASH( SELF, SELF.keys.list, 'kv', $kv, %other ); +} +multi sub postcircumfix:<{ }>(\SELF, Whatever, :$p!, *%other) is raw { + SLICE_MORE_HASH( SELF, SELF.keys.list, 'p', $p, %other ); +} +multi sub postcircumfix:<{ }>(\SELF, Whatever, :$k!, *%other) is raw { + SLICE_MORE_HASH( SELF, SELF.keys.list, 'k', $k, %other ); +} +multi sub postcircumfix:<{ }>(\SELF, Whatever, :$p!, *%other) is raw { + SLICE_MORE_HASH( SELF, SELF.keys.list, 'p', $p, %other ); +} +multi sub postcircumfix:<{ }>(\SELF, Whatever, :$v!, *%other) is raw { + nqp::elems(nqp::getattr(%other,Map,'$!storage')) + ?? SLICE_MORE_HASH( SELF, SELF.keys.list, 'v', $v, %other ) + !! SELF{SELF.keys.list}; +} + +# %h{} +multi sub postcircumfix:<{ }>(\SELF, :$BIND!) is raw { + X::Bind::ZenSlice.new(type => SELF.WHAT).throw; +} +multi sub postcircumfix:<{ }>(\SELF, :$delete!, *%other) is raw { + SLICE_MORE_HASH( SELF, SELF.keys.list, 'delete', $delete, %other ); +} +multi sub postcircumfix:<{ }>(\SELF, :$exists!, *%other) is raw { + SLICE_MORE_HASH( SELF, SELF.keys.list, 'exists', $exists, %other ); +} +multi sub postcircumfix:<{ }>(\SELF, :$kv!, *%other) is raw { + SLICE_MORE_HASH( SELF, SELF.keys.list, 'kv', $kv, %other ); +} +multi sub postcircumfix:<{ }>(\SELF, :$p!, *%other) is raw { + SLICE_MORE_HASH( SELF, SELF.keys.list, 'p', $p, %other ); +} +multi sub postcircumfix:<{ }>(\SELF, :$k!, *%other) is raw { + SLICE_MORE_HASH( SELF, SELF.keys.list, 'k', $k, %other ); +} +multi sub postcircumfix:<{ }>(\SELF, :$p!, *%other) is raw { + SLICE_MORE_HASH( SELF, SELF.keys.list, 'p', $p, %other ); +} +multi sub postcircumfix:<{ }>(\SELF, :$v!, *%other) is raw { + nqp::elems(nqp::getattr(%other,Map,'$!storage')) + ?? SLICE_MORE_HASH( SELF, SELF.keys.list, 'v', $v, %other ) + !! SELF{SELF.keys.list}; +} +multi sub postcircumfix:<{ }>( \SELF, *%other ) is raw { + SELF.ZEN-KEY(|%other); +} + + +proto sub postcircumfix:<{; }>(|) is nodal {*} + +sub MD-HASH-SLICE-ONE-POSITION(\SELF, \indices, \idx, int $dim, \target) { + my int $next-dim = $dim + 1; + if $next-dim < indices.elems { + if nqp::istype(idx, Iterable) && !nqp::iscont(idx) { + for idx { + MD-HASH-SLICE-ONE-POSITION(SELF, indices, $_, $dim, target) + } + } + elsif nqp::istype(idx, Str) { + MD-HASH-SLICE-ONE-POSITION(SELF.AT-KEY(idx), indices, indices.AT-POS($next-dim), $next-dim, target) + } + elsif nqp::istype(idx, Whatever) { + for SELF.keys { + MD-HASH-SLICE-ONE-POSITION(SELF.AT-KEY($_), indices, indices.AT-POS($next-dim), $next-dim, target) + } + } + else { + MD-HASH-SLICE-ONE-POSITION(SELF.AT-KEY(idx), indices, indices.AT-POS($next-dim), $next-dim, target) + } + } + else { + if nqp::istype(idx, Iterable) && !nqp::iscont(idx) { + for idx { + MD-HASH-SLICE-ONE-POSITION(SELF, indices, $_, $dim, target) + } + } + elsif nqp::istype(idx, Str) { + nqp::push(target, SELF.AT-KEY(idx)) + } + elsif nqp::istype(idx, Whatever) { + for SELF.keys { + nqp::push(target, SELF.AT-KEY($_)) + } + } + else { + nqp::push(target, SELF.AT-KEY(idx)) + } + } +} + +multi sub postcircumfix:<{; }>(\SELF, @indices) { + my \target = IterationBuffer.new; + MD-HASH-SLICE-ONE-POSITION(SELF, @indices, @indices.AT-POS(0), 0, target); + nqp::p6bindattrinvres(nqp::create(List), List, '$!reified', target) +} + +multi sub postcircumfix:<{; }>(\SELF, @indices, :$exists!) { + sub recurse-at-key(\SELF, \indices) { + my \idx := indices[0]; + my \exists := SELF.EXISTS-KEY(idx); + nqp::if( + nqp::istype(idx, Iterable), + idx.map({ |recurse-at-key(SELF, ($_, |indices.skip.cache)) }).List, + nqp::if( + nqp::iseq_I(indices.elems, 1), + exists, + nqp::if( + exists, + recurse-at-key(SELF{idx}, indices.skip.cache), + nqp::stmts( + (my \times := indices.map({ .elems }).reduce(&[*])), + nqp::if( + nqp::iseq_I(times, 1), + False, + (False xx times).List + ) + ).head + ) + ) + ); + } + + recurse-at-key(SELF, @indices) +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/HyperConfiguration.pm rakudo-2018.03/src/core/HyperConfiguration.pm --- rakudo-2018.02.1/src/core/HyperConfiguration.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/HyperConfiguration.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,8 +0,0 @@ -# Configuration for hyper/race, controlling how we parallelize (number of -# items at a time, and number of threads). -my class HyperConfiguration { - has int $.batch; - has Int $.degree; -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/HyperConfiguration.pm6 rakudo-2018.03/src/core/HyperConfiguration.pm6 --- rakudo-2018.02.1/src/core/HyperConfiguration.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/HyperConfiguration.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,8 @@ +# Configuration for hyper/race, controlling how we parallelize (number of +# items at a time, and number of threads). +my class HyperConfiguration { + has int $.batch; + has Int $.degree; +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/HyperSeq.pm rakudo-2018.03/src/core/HyperSeq.pm --- rakudo-2018.02.1/src/core/HyperSeq.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/HyperSeq.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -# A HyperSeq performs batches of work in parallel, but retains order of output -# values relative to input values. -my class HyperSeq does Iterable does Sequence { - has HyperConfiguration $.configuration; - has Rakudo::Internals::HyperWorkStage $!work-stage-head; - - submethod BUILD(:$!configuration!, :$!work-stage-head!) {} - - method iterator(HyperSeq:D: --> Iterator) { - my $joiner := Rakudo::Internals::HyperToIterator.new: - source => $!work-stage-head; - Rakudo::Internals::HyperPipeline.start($joiner, $!configuration); - $joiner - } - - method grep(HyperSeq:D: $matcher, *%options) { - Rakudo::Internals::HyperRaceSharedImpl.grep: - self, $!work-stage-head, $matcher, %options - } - - method map(HyperSeq:D: $matcher, *%options) { - Rakudo::Internals::HyperRaceSharedImpl.map: - self, $!work-stage-head, $matcher, %options - } - - method hyper(HyperSeq:D:) { self } - - method is-lazy() { False } - - method race(HyperSeq:D:) { - RaceSeq.new(:$!configuration, :$!work-stage-head) - } - - multi method serial(HyperSeq:D:) { self.Seq } - - method sink(--> Nil) { - Rakudo::Internals::HyperRaceSharedImpl.sink(self, $!work-stage-head) - } -} - -# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/HyperSeq.pm6 rakudo-2018.03/src/core/HyperSeq.pm6 --- rakudo-2018.02.1/src/core/HyperSeq.pm6 1970-01-01 00:00:00.000000000 +0000 +++ rakudo-2018.03/src/core/HyperSeq.pm6 2018-03-19 11:27:21.000000000 +0000 @@ -0,0 +1,41 @@ +# A HyperSeq performs batches of work in parallel, but retains order of output +# values relative to input values. +my class HyperSeq does Iterable does Sequence { + has HyperConfiguration $.configuration; + has Rakudo::Internals::HyperWorkStage $!work-stage-head; + + submethod BUILD(:$!configuration!, :$!work-stage-head!) {} + + method iterator(HyperSeq:D: --> Iterator) { + my $joiner := Rakudo::Internals::HyperToIterator.new: + source => $!work-stage-head; + Rakudo::Internals::HyperPipeline.start($joiner, $!configuration); + $joiner + } + + method grep(HyperSeq:D: $matcher, *%options) { + Rakudo::Internals::HyperRaceSharedImpl.grep: + self, $!work-stage-head, $matcher, %options + } + + method map(HyperSeq:D: $matcher, *%options) { + Rakudo::Internals::HyperRaceSharedImpl.map: + self, $!work-stage-head, $matcher, %options + } + + method hyper(HyperSeq:D:) { self } + + method is-lazy() { False } + + method race(HyperSeq:D:) { + RaceSeq.new(:$!configuration, :$!work-stage-head) + } + + multi method serial(HyperSeq:D:) { self.Seq } + + method sink(--> Nil) { + Rakudo::Internals::HyperRaceSharedImpl.sink(self, $!work-stage-head) + } +} + +# vim: ft=perl6 expandtab sw=4 diff -Nru rakudo-2018.02.1/src/core/Instant.pm rakudo-2018.03/src/core/Instant.pm --- rakudo-2018.02.1/src/core/Instant.pm 2018-02-23 05:08:44.000000000 +0000 +++ rakudo-2018.03/src/core/Instant.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,141 +0,0 @@ -my class Date { ... } -my class DateTime { ... } -my class Duration {... } - -my class Instant is Cool does Real { - has Rat $.tai; - # A linear count of seconds since 1970-01-01T00:00:00Z, plus - # Rakudo::Internals.initial-offset. Thus, $.tai matches TAI from 1970 - # to the present. - - method SET-SELF($!tai) { self } # cannot be private because of operators - - method new(*@) { X::Cannot::New.new(class => self).throw } - - proto method from-posix(|) {*} - multi method from-posix($posix) { - nqp::create(Instant).SET-SELF( - Rakudo::Internals.tai-from-posix($posix,0).Rat - ) - } - multi method from-posix($posix, Bool $prefer-leap-second) { - # $posix is in general not expected to be an integer. - # If $prefer-leap-second is true, 915148800 is interpreted to - # mean 1998-12-31T23:59:60Z rather than 1999-01-01T00:00:00Z. - nqp::create(Instant).SET-SELF( - Rakudo::Internals.tai-from-posix($posix,$prefer-leap-second).Rat - ) - } - - method to-posix() { - # The inverse of .from-posix, except that the second return - # value is true if *and only if* this Instant is in a leap - # second. - Rakudo::Internals.posix-from-tai($!tai) - } - - multi method Str(Instant:D:) { - 'Instant:' ~ $!tai - } - multi method perl(Instant:D:) { - "Instant.from-posix{self.to-posix.perl}"; - } - method Bridge(Instant:D:) { $!tai.Bridge } - method Num (Instant:D:) { $!tai.Num } - method Rat (Instant:D:) { $!tai } - method Int (Instant:D:) { $!tai.Int } - method narrow(Instant:D:) { $!tai.narrow } - - method Date(Instant:D:) { Date.new(self) } - method DateTime(Instant:D:) { DateTime.new(self) } - method Instant() { self } - -# TODO: should be the new .gist, probably -# method Str() { -# 'Instant:' ~ default-formatter -# ::DateTime.new(self), :subseconds -# } -} - -multi sub infix:«cmp»(Instant:D $a, Instant:D $b) { - $a.tai <=> $b.tai } - -multi sub infix:«<=>»(Instant:D $a, Instant:D $b) { - $a.tai <=> $b.tai -} - -multi sub infix:«==»(Instant:D $a, Instant:D $b) { - $a.tai == $b.tai -} - -multi sub infix:«!=»(Instant:D $a, Instant:D $b) { - $a.tai != $b.tai -} -multi sub infix:«≠»(Instant:D $a, Instant:D $b) { - $a.tai ≠ $b.tai -} - -multi sub infix:«<»(Instant:D $a, Instant:D $b) { - $a.tai < $b.tai -} - -multi sub infix:«>»(Instant:D $a, Instant:D $b) { - $a.tai > $b.tai -} - -multi sub infix:«<=»(Instant:D $a, Instant:D $b) { - $a.tai <= $b.tai -} -multi sub infix:«≤»(Instant:D $a, Instant:D $b) { - $a.tai ≤ $b.tai -} - -multi sub infix:«>=»(Instant:D $a, Instant:D $b) { - $a.tai >= $b.tai -} -multi sub infix:«≥»(Instant:D $a, Instant:D $b) { - $a.tai ≥ $b.tai -} - -multi sub infix:<+>(Instant:D $a, Real:D $b) { - nqp::create(Instant).SET-SELF($a.tai + $b.Rat) -} -multi sub infix:<+>(Real:D $a, Instant:D $b) { - nqp::create(Instant).SET-SELF($a.Rat + $b.tai) -} -multi sub infix:<+>(Instant:D $a, Duration:D $b) { - nqp::create(Instant).SET-SELF($a.tai + $b.tai) -} -multi sub infix:<+>(Duration:D $a, Instant:D $b) { - nqp::create(Instant).SET-SELF($a.tai + $b.tai) -} - -multi sub infix:<->(Instant:D $a, Instant:D $b) { - Duration.new: $a.tai - $b.tai; -} -multi sub infix:<->(Instant:D $a, Real:D $b) { - nqp::create(Instant).SET-SELF($a.tai - $b.Rat) -} - -sub term: