From: Vincent Pit Date: Fri, 8 Aug 2008 18:46:52 +0000 (+0200) Subject: Fix map/grep handling of returns in block with a new cumulate function X-Git-Tag: v0.03~11 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Nary.git;a=commitdiff_plain;h=fd35681c6f0a1e84d407dbe4fcc7a3c25e4d8851 Fix map/grep handling of returns in block with a new cumulate function --- diff --git a/Nary.xs b/Nary.xs index dc5612b..c3f1bc5 100644 --- a/Nary.xs +++ b/Nary.xs @@ -59,7 +59,7 @@ CODE: XSRETURN_IV(res); } hv = (HV *) SvRV(sv); - res = hv_exists(hv, "0", 1) && hv_iterinit(hv) == 1; + res = hv_iterinit(hv) == 1 && hv_exists(hv, "0", 1); XSRETURN_IV(res); void @@ -76,7 +76,7 @@ CODE: XSRETURN_IV(res); } hv = (HV *) SvRV(sv); - res = hv_exists(hv, "list", 4) && hv_iterinit(hv) == 1; + res = hv_iterinit(hv) == 1 && hv_exists(hv, "list", 4); XSRETURN_IV(res); void @@ -223,6 +223,49 @@ CODE: ST(0) = sv_2mortal(newRV_noinc((SV *) res)); XSRETURN(1); +void +cumulate(SV *sv, SV *nsv, SV *csv) +PROTOTYPE: $$$ +PREINIT: + HV *res; + SV *val; + HE *key; + NV c0, c, a; + UV i, n; +CODE: + if (!SvOK(sv)) + XSRETURN_UNDEF; + n = SvUV(nsv); + c0 = SvNV(csv); + if (!n) { + ST(0) = sv_2mortal(newSVuv(0)); + XSRETURN(1); + } + if (!SvROK(sv) || !c0) { + ST(0) = sv; + XSRETURN(1); + } + sv = SvRV(sv); + if (!hv_iterinit((HV *) sv)) + XSRETURN_UNDEF; + c = 1; + a = c0; + for (; n > 0; n /= 2) { + if (n % 2) + c *= a; + a *= a; + } + c = (1 - c) / (1 - c0); + res = newHV(); + while (key = hv_iternext((HV *) sv)) { + SV *k = HeSVKEY_force(key); + val = newSVnv(c * SvNV(HeVAL(key))); + if (!hv_store_ent(res, k, val, 0)) + SvREFCNT_dec(val); + } + ST(0) = sv_2mortal(newRV_noinc((SV *) res)); + XSRETURN(1); + void combine(...) PROTOTYPE: @ diff --git a/lib/Sub/Nary.pm b/lib/Sub/Nary.pm index 21f53b0..611f780 100644 --- a/lib/Sub/Nary.pm +++ b/lib/Sub/Nary.pm @@ -488,10 +488,17 @@ sub pp_leaveloop { } $op = $op->sibling; - my $r = (name($op->first) eq 'and') ? ($self->inspect($op->first->first->sibling))[0] - : ($self->inspect($op))[0]; + my $r; + if (name($op->first) eq 'and') { + ($r, my $l) = ($self->inspect($op->first->first))[0]; + return $r, $l if $r and zero $l; + $r = ($self->inspect($op->first->first->sibling))[0]; + } else { + $r = ($self->inspect($op))[0]; + } + my $c = 1 - count $r; - diag "& leaveloop" if $DEBUG; + diag "& leaveloop $c" if $DEBUG; return $r, $c ? { 0 => $c } : undef; } @@ -522,7 +529,7 @@ sub pp_flip { } my $c = 1 - count $r; - return $r, ($l && $c) ? { 'list' => $c } : undef + return $r, $c ? { 'list' => $c } : undef } sub pp_grepwhile { @@ -534,19 +541,18 @@ sub pp_grepwhile { my ($r2, $l2) = $self->inspect($op->sibling); return $r2, $l2 if $r2 and zero $l2; - diag Dumper [ $r2, $l2 ] if $DEBUG; - my $c = count $l2; # First one to happen + my $c2 = count $l2; # First one to happen my ($r1, $l1) = $self->inspect($op); - diag Dumper [ $r1, $l1 ] if $DEBUG; - return (add $r2, scale $c, $r1), undef if $r1 and zero $l1 and not zero $l2; - return { 'list' => 1 }, undef if list $l2; + return (add $r2, scale $c2, $r1), undef if $r1 and zero $l1 and not zero $l2; + diag Dumper [ [ $r1, $l1 ], [ $r2, $l2 ] ] if $DEBUG; + my $c1 = count $l1; $l2 = { $l2 => 1 } unless ref $l2; - my $r = add $r2, scale $c, - normalize - add map { power $r1, $_, $l2->{$_} } keys %$l2; - $c = 1 - count $r; + my $r = add $r2, + scale $c2, + add map { scale $l2->{$_}, cumulate $r1, $_, $c1 } keys %$l2; + my $c = 1 - count $r; return $r, $c ? { ((zero $l2) ? 0 : 'list') => $c } : undef; } @@ -559,17 +565,18 @@ sub pp_mapwhile { my ($r2, $l2) = $self->inspect($op->sibling); return $r2, $l2 if $r2 and zero $l2; - my $c = count $l2; # First one to happen + my $c2 = count $l2; # First one to happen my ($r1, $l1) = $self->inspect($op); - return (add $r2, scale $c, $r1), undef if $r1 and zero $l1 and not zero $l2; + return (add $r2, scale $c2, $r1), undef if $r1 and zero $l1 and not zero $l2; diag Dumper [ [ $r1, $l1 ], [ $r2, $l2 ] ] if $DEBUG; + my $c1 = count $l1; $l2 = { $l2 => 1 } unless ref $l2; - my $r = add $r2, scale $c, - normalize - add map { power $r1, $_, $l2->{$_} } keys %$l2; - $c = 1 - count $r; + my $r = add $r2, + scale $c2, + add map { scale $l2->{$_}, cumulate $r1, $_, $c1 } keys %$l2; + my $c = 1 - count $r; my $l = scale $c, normalize add map { power $l1, $_, $l2->{$_} } keys %$l2; return $r, $l; } diff --git a/samples/cx.pl b/samples/cx.pl index 8717d39..69bef74 100755 --- a/samples/cx.pl +++ b/samples/cx.pl @@ -63,7 +63,7 @@ sub ifr { } my $code = \&wut; - +$code = sub { while (do { return 2, 3 }) { } }; my $bd = B::Deparse->new(); print STDERR $bd->coderef2text($code), "\n"; diff --git a/t/20-return.t b/t/20-return.t index 48d3a54..c48eeef 100644 --- a/t/20-return.t +++ b/t/20-return.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 72; +use Test::More tests => 76; use Sub::Nary; @@ -60,6 +60,7 @@ my @tests = ( [ sub { for (1, 2, 3) { return } }, 0 ], [ sub { for (1, 2, 3) { } return 1, 2; }, 2 ], + [ sub { for (do { return 1, 2, 3 }) { } return 1, 2; }, 3 ], [ sub { for ($x, 1, $y) { return 1, 2 } }, 2 ], [ sub { for (@a) { return 1, do { $x } } }, 2 ], [ sub { for (keys %h) { return do { 1 }, do { return @a[0, 2] } } }, 2 ], @@ -72,6 +73,7 @@ my @tests = ( [ sub { while (1) { return 1, 2 } }, 2 ], [ sub { while (1) { last; return 1, 2 } }, 2 ], [ sub { return 1, 2 while 1 }, 2 ], + [ sub { while (do { return 2, 3 }) { } }, 2 ], [ sub { eval { return } }, 0 ], [ sub { eval { return 1, 2 } }, 2 ], @@ -87,6 +89,8 @@ my @tests = ( [ sub { grep { $_ > 1 } do { return 2, 4; 5 .. 10 } }, 2 ], [ sub { grep { return 2, 4 } () }, 0 ], [ sub { grep { return $_ ? 2 : (3, 4) } 7 .. 8 }, $exp_2 ], + [ sub { grep { return 2 if $_; 3 } 7 .. 8 }, + { 1 => 0.75, list => 0.25 } ], [ sub { grep { $_ > 1 } do { return $x ? 7 : (8, 9) } }, $exp_2 ], [ sub { grep { return $_ ? 2 : (3, 4) } do { return 3 .. 5 if $x; } }, { 3 => 0.5, 1 => 0.25, 2 => 0.25 } ], @@ -97,6 +101,8 @@ my @tests = ( [ sub { map { $_ + 1 } do { return 2, 4; 5 .. 10 } }, 2 ], [ sub { map { return 2, 4 } () }, 0 ], [ sub { map { return $_ ? 2 : (3, 4) } 7 .. 8 }, $exp_2 ], + [ sub { map { return 2 if $_; 3 } 7 .. 8 }, + { 1 => 0.75, 2 => 0.25 } ], [ sub { map { $_ > 1 } do { return $x ? 7 : (8, 9) } }, $exp_2 ], [ sub { map { return $_ ? 2 : (3, 4) } do { return 3 .. 5 if $x; } }, { 3 => 0.5, 1 => 0.25, 2 => 0.25 } ], diff --git a/t/24-ops.t b/t/24-ops.t index 9b7f970..b636cf8 100644 --- a/t/24-ops.t +++ b/t/24-ops.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 48; +use Test::More tests => 49; use Sub::Nary; @@ -47,6 +47,7 @@ my @tests = ( [ sub { delete @h{qw/foo bar baz/} }, 3 ], [ sub { grep { 1 } 1 .. 10 }, 'list' ], + [ sub { grep { 1 } @_ }, 'list' ], [ sub { map { $_ } 1 .. 3 }, 3 ], [ sub { map { () } @_ }, 0 ], diff --git a/t/92-pod-coverage.t b/t/92-pod-coverage.t index 6bc94f3..1889ea5 100644 --- a/t/92-pod-coverage.t +++ b/t/92-pod-coverage.t @@ -15,4 +15,9 @@ my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; -all_pod_coverage_ok({ also_private => [ qr/^pp_/, qr/^inspect/, qw/add combine power normalize scale count const_sv enter gv_or_padgv name null zero list padval scalops tag/ ] }); +all_pod_coverage_ok({ also_private => [ + qr/^inspect/, qr/^pp_/, qw/enter/, + qw/tag scalops/, + qw/null zero list count scale normalize add combine cumulate power/, + qw/name const_sv gv_or_padgv padval/ +] });