for/while (...) { return if } should be interpreted as 'list'

[perl/modules/Sub-Nary.git] / lib / Sub / Nary.pm

diff --git a/lib/Sub/Nary.pm b/lib/Sub/Nary.pm
index d5a96452a1418f7a0e3382d3e9c32d7ae33151f9..14b882285723a2e3d20bbb7472c8502df1166d8a 100644 (file)
--- a/lib/Sub/Nary.pm
+++ b/lib/Sub/Nary.pm
@@ -6,7 +6,6 @@ use strict;
 use warnings;
 
 use Carp qw/croak/;
-use List::Util qw/reduce/;
 
 use B qw/class ppname svref_2object OPf_KIDS/;
 
@@ -193,13 +192,6 @@ sub power {
  return $r;
 }
 
-sub add {
- reduce {
-  $a->{$_} += $b->{$_} for keys %$b;
-  $a
- } map { (ref) ? $_ : { $_ => 1 } } grep defined, @_;
-}
-
 my %ops;
 
 $ops{$_} = 1      for scalops;
@@ -281,7 +273,7 @@ sub inspect {
   if (null $op) {
    # If the logop has no else branch, it can also return the *scalar* result of
    # the conditional
-   $l3 = { 1 => $c };
+   $l3 = { 1 => 1 };
   } else {
    ($r3, $l3) = $self->inspect($op);
   }
@@ -319,18 +311,20 @@ sub inspect_kids {
    $op = $op->first;
    redo;
   }
-  diag "> $n ($c)" if $DEBUG;
+  diag "> $n" if $DEBUG;
   my ($rc, $lc) = $self->inspect($op);
+  $c = 1 - count $r;
+  diag Dumper [ $c, $r, \@l, $rc, $lc ] if $DEBUG;
   $r = add $r, scale $c, $rc if defined $rc;
-  if ($rc and not defined $lc) {
+  if (not defined $lc) {
    @l = ();
    last;
   }
   push @l, scale $c, $lc;
-  $c *= count $lc if defined $lc;
  }
 
- my $l = combine @l;
+# diag Dumper \@l if $DEBUG;
+ my $l = scale +(1 - count $r), normalize combine @l;
 
  return $r, $l;
 }
@@ -446,7 +440,7 @@ sub pp_const {
  if ($c eq 'AV') {
   $n = $sv->FILL + 1
  } elsif ($c eq 'HV') {
-  $n = 2 * $sv->FILL
+  $n = 2 * $sv->KEYS
  }
 
  return undef, $n
@@ -490,16 +484,32 @@ sub pp_leaveloop {
 
  $op = $op->first;
  my ($r1, $l1);
- if (name($op) eq 'enteriter') {
+ my $for;
+ if (name($op) eq 'enteriter') { # for loop ?
+  $for = 1;
   ($r1, $l1) = $self->inspect($op);
-  return $r1, $l1 if $r1 and zero $l1;
+  return $r1, $l1 if defined $r1 and zero $l1;
  }
 
  $op = $op->sibling;
- my $r = (name($op->first) eq 'and') ? ($self->inspect($op->first->first->sibling))[0]
-                                     : ($self->inspect($op))[0];
+ my ($r2, $l2);
+ if (name($op->first) eq 'and') {
+  ($r2, $l2) = $self->inspect($op->first->first);
+  return $r2, $l2 if defined $r2 and zero $l2;
+  my $c = count $l2;
+  return { list => 1 }, undef if !$for and defined $r2;
+  my ($r3, $l3) = $self->inspect($op->first->first->sibling);
+  return { list => 1 }, undef if defined $r3 and defined $l3;
+  $r2 = add $r2, scale $c, $r3;
+ } else {
+  ($r2, $l2) = $self->inspect($op);
+  return { list => 1 }, undef if defined $r2 and defined $l2;
+ }
+
+ my $r = (defined $r1) ? add $r1, scale +(1 - count $r1), $r2
+                       : $r2;
  my $c = 1 - count $r;
- diag "& leaveloop" if $DEBUG;
+ diag "& leaveloop $c" if $DEBUG;
  return $r, $c ? { 0 => $c } : undef;
 }
 
@@ -530,7 +540,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 {
@@ -542,19 +552,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;
 }
 
@@ -567,17 +576,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;
 }
@@ -596,7 +606,7 @@ C<wantarray> isn't specialized when encountered in the optree.
 
 L<perl> 5.8.1.
 
-L<Carp> (standard since perl 5), L<B> (since perl 5.005), L<XSLoader> (since perl 5.006) and L<List::Util> (since perl 5.007003).
+L<Carp> (standard since perl 5), L<B> (since perl 5.005) and L<XSLoader> (since perl 5.006).
 
 =head1 AUTHOR