Fix map/grep handling of returns in block with a new cumulate function

diff --git a/Nary.xs b/Nary.xs
index dc5612b1b46cdf0fe47cf6ef624923906bf808f6..c3f1bc59e1ec590ba587842e815de37a6950bd28 100644 (file)
--- 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 21f53b0be6480a9b9e308d6677a783b533f13afa..611f780d617ad220649149b56ab64094db53cb59 100644 (file)
--- 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 8717d395ea41154cf06f4d477138397d0cfdc975..69bef742f77521688e7da9e8f88f232822022682 100755 (executable)
--- 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 48d3a54a1cbdbe9a649c5cc2186cbbc0b1baf05f..c48eeeff15c3bef5c82b140f0031fe94b58b2b5b 100644 (file)
--- 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 9b7f97021740213766b1828f7a92b5d9aecde2ed..b636cf847f3c297999e49a617498d89bf0cbe1e8 100644 (file)
--- 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 6bc94f30b6387e2182dca6a8f09a4e4730f2f132..1889ea5aacfb96724fab016eadc63ebd3b80b0fe 100644 (file)
--- 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/
+] });