Commit a3f5f0f7 authored by Daniel Dehennin's avatar Daniel Dehennin

New upstream version 2017.05

parent eb51a2c3
......@@ -623,6 +623,7 @@ U: paultcochrane
E: paul@liekut.de
N: Pawel Murias
U: pmurias
E: pawelmurias@gmail.com
N: Pepe Schwarz
......@@ -849,4 +850,8 @@ U: mmcleric
E: me@berekuk.ru
D: Whatever-currying, colonpair fixes
N: eater
U: the-eater
E: perl6@eaterofco.de
=cut
......@@ -54,9 +54,9 @@
If you would like readline-like features, such as command history, line
editing, and tab completion for builtins, you should install the Linenoise
module via panda:
module via zef:
$ panda install Linenoise
$ zef install Linenoise
Important: To run Rakudo from outside the build directory, you must run
......
......@@ -109,6 +109,7 @@ docs/announce/2017.04.1.md
docs/announce/2017.04.2.md
docs/announce/2017.04.3.md
docs/announce/2017.04.md
docs/announce/2017.05.md
docs/architecture.html
docs/architecture.svg
docs/ChangeLog
......@@ -289,6 +290,7 @@ src/core/Rakudo/Internals.pm
src/core/Rakudo/Internals/VMBackedDecoder.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
......
......@@ -123,9 +123,9 @@ See [our contribution guidelines](https://github.com/rakudo/rakudo/blob/nom/CONT
If you would like simple history and tab completion in the perl6 executable,
you need to install the Linenoise module. The recommended way to install
Linenoise is via [panda](https://github.com/tadzik/panda):
Linenoise is via [zef](https://github.com/ugexe/zef):
panda install Linenoise
zef install Linenoise
An alternative is to use a third-party program such as [rlwrap](http://utopia.knoware.nl/~hlub/uck/rlwrap/#rlwrap).
......
This diff is collapsed.
......@@ -18,6 +18,11 @@ of multiple ecosystem modules. This will prevent issues that require point relea
The tarball for this release is available from <http://rakudo.org/downloads/rakudo/>.
**This point release requires a newer NQP and MoarVM than 2017.04**. There has not been any further NQP or MoarVM *release* tags, but the version/git tags required are at least:
* NQP 2017.04-24-g87501f7b
* MoarVM 2017.04-44-gf0db8822
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
......
This diff is collapsed.
......@@ -428,7 +428,9 @@ Previous releases were bundled as part of monthly Parrot releases.
2017-03-18 Rakudo #109 "2017.03" (Zoffix + NeuralAnomaly)
2017-04-17 Rakudo #110 "2017.04" (Zoffix + NeuralAnomaly)
2017-04-18 2017.04.1 (Zoffix)
2017-04-18 2017.04.2 (Zoffix)
2017-04-23 2017.04.3 (Zoffix)
=head1 COPYRIGHT
Copyright (C) 2009-2017, The Perl Foundation.
......
......@@ -882,7 +882,7 @@ package Runner {
}
}
my $parser = TAP::Parser.new(:@handlers);
for $proc.out.lines -> $line {
for $proc.out.lines(:close) -> $line {
$parser.add-data($line);
}
$parser.close-data();
......
......@@ -114,7 +114,7 @@ multi sub pass($desc = '') is export {
multi sub ok(Mu $cond, $desc = '') is export {
$time_after = nqp::time_n;
my $ok = proclaim(?$cond, $desc);
my $ok = proclaim($cond, $desc);
$time_before = nqp::time_n;
$ok or ($die_on_fail and die-on-fail) or $ok;
}
......@@ -142,7 +142,7 @@ multi sub is(Mu $got, Mu:U $expected, $desc = '') is export {
?? False
!! $got === $expected;
$ok = proclaim(?$test, $desc);
$ok = proclaim($test, $desc);
if !$test {
_diag "expected: ($expected.^name())\n"
~ " got: ($got.^name())";
......@@ -162,7 +162,7 @@ multi sub is(Mu $got, Mu:D $expected, $desc = '') is export {
!! nqp::eqaddr($got.WHAT, Mu)
?? False
!! $got eq $expected;
$ok = proclaim(?$test, $desc);
$ok = proclaim($test, $desc);
if !$test {
if try $got .Str.subst(/\s/, '', :g)
eq $expected.Str.subst(/\s/, '', :g)
......@@ -194,7 +194,7 @@ multi sub isnt(Mu $got, Mu:U $expected, $desc = '') is export {
}
else {
my $test = $got !=== $expected;
$ok = proclaim(?$test, $desc);
$ok = proclaim($test, $desc);
if !$test {
_diag "expected: anything except '$expected.perl()'\n"
~ " got: '$got.perl()'";
......@@ -209,7 +209,7 @@ multi sub isnt(Mu $got, Mu:D $expected, $desc = '') is export {
my $ok;
if $got.defined { # also hack to deal with Failures
my $test = $got ne $expected;
$ok = proclaim(?$test, $desc);
$ok = proclaim($test, $desc);
if !$test {
_diag "expected: anything except '$expected.perl()'\n"
~ " got: '$got.perl()'";
......@@ -238,7 +238,7 @@ multi sub cmp-ok(Mu $got, $op, Mu $expected, $desc = '') is export {
// &CALLERS::("infix:<$op.subst(/<?before <[<>]>>/, "\\", :g)>"); #3
if $matcher {
$ok = proclaim(?$matcher($got,$expected), $desc);
$ok = proclaim($matcher($got,$expected), $desc);
if !$ok {
_diag "expected: '{$expected // $expected.^name}'\n"
~ " matcher: '{$matcher.?name || $matcher.^name}'\n"
......@@ -265,7 +265,7 @@ multi sub is_approx(Mu $got, Mu $expected, $desc = '') is export {
$time_after = nqp::time_n;
my $tol = $expected.abs < 1e-6 ?? 1e-5 !! $expected.abs * 1e-6;
my $test = ($got - $expected).abs <= $tol;
my $ok = proclaim(?$test, $desc);
my $ok = proclaim($test, $desc);
unless $test {
_diag "expected: $expected\n"
~ "got: $got";
......@@ -467,32 +467,46 @@ multi sub can-ok(
}
multi sub like(
Str $got, Regex $expected,
$got, Regex $expected,
$desc = "text matches '$expected.perl()'"
) is export {
$time_after = nqp::time_n;
$got.defined; # Hack to deal with Failures
my $test = $got ~~ $expected;
my $ok = proclaim(?$test, $desc);
if !$test {
_diag " expected: '$expected.perl()'\n"
~ " got: '$got'";
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()'";
}
$time_before = nqp::time_n;
$ok or ($die_on_fail and die-on-fail) or $ok;
}
multi sub unlike(
Str $got, Regex $expected,
$got, Regex $expected,
$desc = "text does not match '$expected.perl()'"
) is export {
$time_after = nqp::time_n;
$got.defined; # Hack to deal with Failures
my $test = !($got ~~ $expected);
my $ok = proclaim(?$test, $desc);
if !$test {
_diag " expected: '$expected.perl()'\n"
~ " got: '$got'";
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()'";
}
$time_before = nqp::time_n;
$ok or ($die_on_fail and die-on-fail) or $ok;
......@@ -547,13 +561,22 @@ multi sub eval-lives-ok(Str $code, $reason = '') is export {
$ok or ($die_on_fail and die-on-fail) or $ok;
}
multi sub is-deeply(Seq $got, Seq $expected, $reason = '') is export {
######################################################################
# The fact that is-deeply converts Seq args to Lists is actually a bug
# that ended up being too-much-pain-for-little-gain to fix. Using Seqs
# breaks ~65 tests in 6.c-errata and likely breaks a lot of module
# tests as well. So... for the foreseeable future we decided to leave it
# as is. If a user really wants to ensure Seq comparison, there's always
# `cmp-ok` with `eqv` op.
# https://irclog.perlgeek.de/perl6-dev/2017-05-04#i_14532363
######################################################################
multi sub is-deeply(Seq:D $got, Seq:D $expected, $reason = '') is export {
is-deeply $got.cache, $expected.cache, $reason;
}
multi sub is-deeply(Seq $got, Mu $expected, $reason = '') is export {
multi sub is-deeply(Seq:D $got, Mu $expected, $reason = '') is export {
is-deeply $got.cache, $expected, $reason;
}
multi sub is-deeply(Mu $got, Seq $expected, $reason = '') is export {
multi sub is-deeply(Mu $got, Seq:D $expected, $reason = '') is export {
is-deeply $got, $expected.cache, $reason;
}
multi sub is-deeply(Mu $got, Mu $expected, $reason = '') is export {
......@@ -638,7 +661,8 @@ sub eval_exception($code) {
$!;
}
sub proclaim($cond, $desc is copy ) {
# Take $cond as Mu so we don't thread with Junctions:
sub proclaim(Bool(Mu) $cond, $desc is copy ) {
_init_io() unless $output;
# exclude the time spent in proclaim from the test time
$num_of_tests_run = $num_of_tests_run + 1;
......
......@@ -7,7 +7,7 @@ use QAST;
my $wantwant := Mu;
my int $?BITS := nqp::iseq_i(0x1ffffffff,8589934591) ?? 64 !! 32;
my int $?BITS := nqp::isgt_i(nqp::add_i(2147483648, 1), 0) ?? 64 !! 32;
sub block_closure($code) {
my $closure := QAST::Op.new(
......@@ -6233,7 +6233,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
}
elsif $elem ~~ QAST::Op && $elem.name eq '&DYNAMIC' &&
$elem[0] ~~ QAST::Want && $elem[0][1] eq 'Ss' &&
$elem[0][2] ~~ QAST::SVal && nqp::substr($elem[0][2].value, 0, 1) eq '%' {
$elem[0][2] ~~ QAST::SVal && nqp::eqat($elem[0][2].value, '%', 0) {
# first item is a hash (%*foo)
$is_hash := 1;
}
......@@ -6252,7 +6252,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
$past := QAST::Op.new(
:op('call'),
:name(
$/.from && nqp::substr($/.orig, $/.from - 1, 1) eq ':' ?? '&circumfix:<:{ }>' !! '&circumfix:<{ }>'
$/.from && nqp::eqat($/.orig, ':', $/.from - 1) ?? '&circumfix:<:{ }>' !! '&circumfix:<{ }>'
),
:node($/)
);
......@@ -6503,7 +6503,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
return 1;
}
elsif $thunky {
for $/.list { if $_.ast { WANTED($_.ast, "EXPR/thunky") if nqp::substr($thunky,$arity,1) eq '.'; $past.push($_.ast); ++$arity; } }
for $/.list { if $_.ast { WANTED($_.ast, "EXPR/thunky") if nqp::eqat($thunky,'.',$arity); $past.push($_.ast); ++$arity; } }
}
else {
for $/.list { if $_.ast { $past.push(WANTED($_.ast,'EXPR/list')); ++$arity; } }
......@@ -6529,10 +6529,10 @@ class Perl6::Actions is HLL::Actions does STDActions {
# Assemble into list of AST of each step in the pipeline.
my @stages;
if $/<infix><sym> eq '==>' {
for @($/) { @stages.push(WANTED($_.ast,'==>')); }
for @($/) { @stages.push($_); }
}
elsif $/<infix><sym> eq '<==' {
for @($/) { @stages.unshift(WANTED($_.ast,'<==')); }
for @($/) { @stages.unshift($_); }
}
else {
$*W.throw($/, 'X::Comp::NYI',
......@@ -6545,7 +6545,9 @@ class Perl6::Actions is HLL::Actions does STDActions {
# will be passed in as var-arg parts to other things. The
# first thing is just considered the result.
my $result := @stages.shift;
$result := WANTED($result.ast, $/<infix><sym>);
for @stages {
my $stage := WANTED($_.ast, $/<infix><sym>);
# Wrap current result in a block, so it's thunked and can be
# called at the right point.
$result := QAST::Block.new( $result );
......@@ -6553,17 +6555,17 @@ class Perl6::Actions is HLL::Actions does STDActions {
# Check what we have. XXX Real first step should be looking
# for @(*) since if we find that it overrides all other things.
# But that's todo...soon. :-)
if $_.isa(QAST::Op) && $_.op eq 'call' {
if $stage.isa(QAST::Op) && $stage.op eq 'call' {
# It's a call. Stick a call to the current supplier in
# as its last argument.
$_.push(QAST::Op.new( :op('call'), $result ));
$stage.push(QAST::Op.new( :op('call'), $result ));
}
elsif $_ ~~ QAST::Var {
elsif $stage ~~ QAST::Var {
# It's a variable. We need code that gets the results, pushes
# them onto the variable and then returns them (since this
# could well be a tap.
my $tmp := QAST::Node.unique('feed_tmp');
$_ := QAST::Stmts.new(
$stage := QAST::Stmts.new(
QAST::Op.new(
:op('bind'),
QAST::Var.new( :scope('local'), :name($tmp), :decl('var') ),
......@@ -6574,17 +6576,22 @@ class Perl6::Actions is HLL::Actions does STDActions {
),
QAST::Op.new(
:op('callmethod'), :name('append'),
$_,
$stage,
QAST::Var.new( :scope('local'), :name($tmp) )
),
QAST::Var.new( :scope('local'), :name($tmp) )
);
$_ := QAST::Op.new( :op('locallifetime'), $_, $tmp );
$stage := QAST::Op.new( :op('locallifetime'), $stage, $tmp );
}
else {
$/.panic('Sorry, do not know how to handle this case of a feed operator yet.');
my str $error := "Only routine calls or variables that can '.push' may appear on either side of feed operators.";
if $stage.isa(QAST::Op) && $stage.op eq 'ifnull' && $stage[0].isa(QAST::Var) && nqp::eqat($stage[0].name, '&', 0) {
$error := "A feed may not sink values into a code object. Did you mean a call like '"
~ nqp::substr($stage[0].name, 1) ~ "()' instead?";
}
$_.PRECURSOR.panic($error);
}
$result := $_;
$result := $stage;
}
# WANTED($result,'make_feed');
......@@ -7374,7 +7381,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
}
method hexint($/) {
my int $chars := nqp::chars($/);
make $chars > ($?BITS == 64 ?? 14 !! 8)
make $chars > ($?BITS == 64 ?? 14 !! 7)
?? string_to_bigint($/, 16, $chars)
!! string_to_int($/, 16, $chars);
}
......@@ -8432,17 +8439,19 @@ class Perl6::Actions is HLL::Actions does STDActions {
}
}
else {
if %info<sigil> eq '@' {
$var.default(
QAST::Op.new( :op<create>,
QAST::WVal.new( :value($*W.find_symbol(['Array'])) )
));
}
elsif %info<sigil> eq '%' {
if (my $is-array := %info<sigil> eq '@') || %info<sigil> eq '%' {
my $role := $is-array ?? 'Positional' !! 'Associative';
my $base-type := $is-array ?? 'Array' !! 'Hash';
$var.default(
QAST::Op.new( :op<create>,
QAST::WVal.new( :value($*W.find_symbol(['Hash'])) )
));
QAST::Op.new(
:op<create>,
QAST::WVal.new(
value => nqp::istype($nomtype, $*W.find_symbol([$role])) && nqp::can($nomtype.HOW, 'role_arguments')
?? $*W.parameterize_type_with_args($/, $*W.find_symbol([$base-type]), $nomtype.HOW.role_arguments($nomtype), nqp::hash)
!! $*W.find_symbol([$base-type])
)));
}
else {
if $spec == 1 {
......@@ -9681,7 +9690,7 @@ class Perl6::RegexActions is QRegex::P6Regex::Actions does STDActions {
if nqp::istype($varast, QAST::Var) {
# See if it's a constant Scalar, in which case we can turn it to
# a Str and use the value as a literal, so we get LTM.
if nqp::substr($varast.name, 0, 1) eq '$' {
if nqp::eqat($varast.name, '$', 0) {
my $constant;
try {
my $found := $*W.find_symbol([$varast.name]);
......
......@@ -63,6 +63,11 @@ class Perl6::Compiler is HLL::Compiler {
$past;
}
method verbose-config() {
self.eval('Compiler.verbose-config(:say)');
nqp::exit(0);
}
method interactive(*%adverbs) {
my $p6repl;
......@@ -77,8 +82,9 @@ class Perl6::Compiler is HLL::Compiler {
$p6repl.repl-loop(:interactive(1), |%adverbs)
}
method usage($name?) {
say(($name ?? $name !! "") ~ " [switches] [--] [programfile] [arguments]
method usage($name?, :$use-stderr = False) {
my $print-func := $use-stderr ?? &note !! &say; # RT #130760
$print-func(($name ?? $name !! "") ~ " [switches] [--] [programfile] [arguments]
With no arguments, enters a REPL. With a \"[programfile]\" or the \"-e\"
option, compiles the given program and, by default, also executes the
......
......@@ -293,7 +293,7 @@ role STD {
self.typed_sorry('X::Syntax::BlockGobbled', what => ($borg<name> // ''));
self.'!cursor_pos'($pos);
self.missing("block (apparently claimed by " ~ ($borg<name> ?? "'" ~ $borg<name> ~ "'" !! "expression") ~ ")");
} elsif $pos > 0 && nqp::substr(self.orig(), $pos - 1, 1) eq '}' {
} elsif $pos > 0 && nqp::eqat(self.orig(), '}', $pos - 1) {
self.missing("block (whitespace needed before curlies taken as a hash subscript?)");
} elsif $has_mystery {
self.missing("block (taken by some undeclared routine?)");
......@@ -3266,7 +3266,7 @@ grammar Perl6::Grammar is HLL::Grammar does STD {
<sym> [ [<longname><circumfix>**0..1] || <.panic: 'Invalid name'> ]
<.explain_mystery> <.cry_sorrows>
{
if $<circumfix> && nqp::substr(self.orig, $<longname>.to, 1) eq '{' {
if $<circumfix> && nqp::eqat(self.orig, '{', $<longname>.to) {
$*BORG<block> := $<circumfix>[0];
$*BORG<name> := 'is ' ~ $<longname>;
}
......
......@@ -316,25 +316,26 @@ my class Binder {
# Also enforce definedness constraints.
if $flags +& $SIG_ELEM_DEFINEDNES_CHECK {
if $flags +& $SIG_ELEM_UNDEFINED_ONLY && nqp::isconcrete($oval) {
if (my $should_be_concrete := $flags +& $SIG_ELEM_DEFINED_ONLY && !nqp::isconcrete($oval)) ||
$flags +& $SIG_ELEM_UNDEFINED_ONLY && nqp::isconcrete($oval)
{
if nqp::defined($error) {
my $class := $nom_type.HOW.name($nom_type);
my $what := $flags +& $SIG_ELEM_INVOCANT
?? "Invocant"
!! "Parameter '$varname'";
$error[0] := "$what requires a type object of type $class, but an object instance was passed. Did you forget a 'multi'?";
}
return $oval.WHAT =:= Junction && nqp::isconcrete($oval)
?? $BIND_RESULT_JUNCTION
!! $BIND_RESULT_FAIL;
}
if $flags +& $SIG_ELEM_DEFINED_ONLY && !nqp::isconcrete($oval) {
if nqp::defined($error) {
my $class := $nom_type.HOW.name($nom_type);
my $what := $flags +& $SIG_ELEM_INVOCANT
?? "Invocant"
!! "Parameter '$varname'";
$error[0] := "$what requires an instance of type $class, but a type object was passed. Did you forget a .new?";
my $method := nqp::getcodeobj(nqp::ctxcode($lexpad)).name;
my $class := $nom_type.HOW.name($nom_type);
my $got := $oval.HOW.name($oval);
my %ex := nqp::gethllsym('perl6', 'P6EX');
if nqp::isnull(%ex) || !nqp::existskey(%ex, 'X::Parameter::RW') {
$method := '<anon>' if nqp::isnull_s($method) || $method eq '';
$error[0] := $flags +& $SIG_ELEM_INVOCANT
?? $should_be_concrete
?? "Invocant of method '$method' must be an object instance of type '$class', not a type object of type '$got'. Did you forget a '.new'?"
!! "Invocant of method '$method' must be a type object of type '$class', not an object instance of type '$got'. Did you forget a 'multi'?"
!! $should_be_concrete
?? "Parameter '$varname' of routine '$method' must be an object instance of type '$class', not a type object of type '$got'. Did you forget a '.new'?"
!! "Parameter '$varname' of routine '$method' must be a type object of type '$class', not an object instance of type '$got'. Did you forget a 'multi'?";
} else {
$error[0] := { nqp::atkey(%ex, 'X::Parameter::InvalidConcreteness')($class, $got, $method, $varname, $should_be_concrete, $flags +& $SIG_ELEM_INVOCANT) };
}
}
return $oval.WHAT =:= Junction && nqp::isconcrete($oval)
?? $BIND_RESULT_JUNCTION
......@@ -848,7 +849,7 @@ my class Binder {
elsif !$suppress_arity_fail {
if nqp::defined($error) {
$error[0] := "Required named argument '" ~
$named_names[0] ~ "' not passed";
nqp::atpos_s($named_names,0) ~ "' not passed";
}
return $BIND_RESULT_FAIL;
}
......
......@@ -17,7 +17,7 @@ role Perl6::Metamodel::MultipleInheritance {
# Adds a parent.
method add_parent($obj, $parent, :$hides) {
if self.is_composed($obj) {
nqp::die("Parents cannot be added to a class after it has been composed");
nqp::die("Parents cannot be added to class '" ~ self.name($obj) ~ "'after it has been composed");
}
if nqp::decont($parent) =:= nqp::decont($obj) {
nqp::die("Class " ~ self.name($obj) ~ " cannot inherit from itself");
......
......@@ -38,6 +38,15 @@ class Perl6::Metamodel::SubsetHOW
"type or a type that can provide one");
}
$!refinee := nqp::decont($refinee);
if nqp::objprimspec($!refinee) {
my %ex := nqp::gethllsym('perl6', 'P6EX');
if nqp::existskey(%ex, 'X::NYI') {
%ex{'X::NYI'}('Subsets of native types');
}
else {
nqp::die("Subsets of native types NYI");
}
}
}
method refinee($obj) {
......
......@@ -4225,7 +4225,7 @@ class Perl6::World is HLL::World {
my $quotes :=
nqp::substr($c.orig, $qs - 1 , 1) ~
nqp::substr($c.orig, $qe, 1);
$quotes := "<<>>" if $quotes eq '<>' && nqp::substr($c.orig, $qe + 1, 1) eq '>';
$quotes := "<<>>" if $quotes eq '<>' && nqp::eqat($c.orig, '>', $qe + 1);
%opts<reason> := %opts<reason> ~ " (runaway multi-line " ~ $quotes ~
" quote starting at line " ~ HLL::Compiler.lineof($c.orig, $qs, :cache(1)) ~ " maybe?)";
}
......
......@@ -119,8 +119,7 @@ my class Any { # declared in BOOTSTRAP
multi method iterator(Any:) { self.list.iterator }
proto method match(|) { $/ := nqp::getlexcaller('$/'); {*} }
multi method match(Any:U: |) { self.Str; nqp::getlexcaller('$/') = Nil }
method match(Any:U: |) { self.Str; nqp::getlexcaller('$/') = Nil }
proto method classify(|) is nodal { * }
multi method classify() {
......@@ -433,12 +432,24 @@ my class Any { # declared in BOOTSTRAP
}
method FLATTENABLE_HASH() is nodal { nqp::hash() }
method Set() is nodal { Set.new-from-pairs(self.list) }
method SetHash() is nodal { SetHash.new-from-pairs(self.list) }
method Bag() is nodal { Bag.new-from-pairs(self.list) }
method BagHash() is nodal { BagHash.new-from-pairs(self.list) }
method Mix() is nodal { Mix.new-from-pairs(self.list) }
method MixHash() is nodal { MixHash.new-from-pairs(self.list) }
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?
method Supply() is nodal { self.list.Supply }
......
......@@ -14,26 +14,36 @@ my class Bag does Baggy {
nqp::if(
nqp::attrinited(self,Bag,'$!total'),
$!total,
$!total := self!TOTAL
$!total := Rakudo::QuantHash.BAG-TOTAL(self.raw_hash)
)
}
#--- object creation methods
multi method new(Bag:_:) { bag() }
#--- interface methods
method SET-SELF(Bag:D: \elems) {
nqp::if(
nqp::elems(elems),
nqp::stmts( # need to have allocated %!elems
nqp::bindattr(%!elems,Map,'$!storage',elems),
self
),
bag()
)
}
multi method DELETE-KEY(Bag:D: \k) {
X::Immutable.new(method => 'DELETE-KEY', typename => self.^name).throw;
}
#--- selection methods
multi method grab(Bag:D: $count?) {
X::Immutable.new( method => 'grab', typename => self.^name ).throw;
}
multi method grabpairs(Bag:D: $count?) {
X::Immutable.new( method => 'grabpairs', typename => self.^name ).throw;
}
#--- coercion methods
method Bag() is nodal { self }
method Mix() is nodal {
multi method Bag(Bag:D:) { self }
multi method Mix(Bag:D:) {
nqp::p6bindattrinvres(nqp::create(Mix),Mix,'%!elems',%!elems)
}
......
......@@ -6,42 +6,36 @@ my class BagHash does Baggy {
Proxy.new(
FETCH => {
nqp::if(
(my $elems := nqp::getattr(%!elems,Map,'$!storage')),
nqp::if(
nqp::existskey($elems,(my $which := k.WHICH)),
nqp::getattr(
nqp::decont(nqp::atkey($elems,$which)),
Pair,
'$!value'
),
0
),
(my $raw := self.raw_hash)
&& nqp::existskey($raw,(my $which := k.WHICH)),
nqp::getattr(nqp::atkey($raw,$which),Pair,'$!value'),
0
)
},
STORE => -> $, Int() $value {
nqp::if(
nqp::istype($value,Failure), # RT 128927
nqp::istype($value,Failure), # RT 128927
$value.throw,
nqp::if(
(my $elems := nqp::getattr(%!elems,Map,'$!storage')),
(my $raw := self.raw_hash),
nqp::if( # allocated hash
nqp::existskey($elems,(my $which := k.WHICH)),
nqp::existskey($raw,(my $which := k.WHICH)),
nqp::if( # existing element
nqp::isgt_i($value,0),
(nqp::getattr(
nqp::decont(nqp::atkey($elems,$which)),
nqp::bindattr(
nqp::atkey($raw,$which),
Pair,
'$!value'
) = $value),
'$!value',
nqp::decont($value)
),
nqp::stmts(
nqp::deletekey($elems,$which),
nqp::deletekey($raw,$which),
0
)
),
nqp::if(
nqp::isgt_i($value,0),
nqp::bindkey($elems,$which,self!PAIR(k,$value)) # new
nqp::isgt_i($value,0), # new
nqp::bindkey($raw,$which,Pair.new(k,nqp::decont($value)))
)
),
nqp::if( # no hash allocated yet
......@@ -50,7 +44,7 @@ my class BagHash does Baggy {
nqp::bindattr(%!elems,Map,'$!storage',
nqp::create(Rakudo::Internals::IterationSet)),
k.WHICH,
self!PAIR(k,$value)
Pair.new(k,nqp::decont($value))
)
)
)
......@@ -59,25 +53,190 @@ my class BagHash does Baggy {
)
}
#--- object creation methods
multi method new(BagHash:_:) { nqp::create(self) }
#--- introspection methods
method Bag(:$view) is nodal {
method total() { Rakudo::QuantHash.BAG-TOTAL(self.raw_hash) }
multi method Bag(BagHash:D: :$view) {
nqp::if(
nqp::getattr(%!elems,Map,'$!storage'),
(my $raw := self.raw_hash) && nqp::elems($raw),
nqp::p6bindattrinvres(
nqp::create(Bag),Bag,'%!elems',
nqp::if($view,%!elems,%!elems.clone)
),
nqp::create(Bag)
bag()
)
}
method BagHash() is nodal { self }
method Mix() is nodal {
multi method BagHash(BagHash:D:) { self }
multi method Mix(BagHash:D:) {
nqp::if(