From: Vincent Pit Date: Wed, 6 Aug 2008 09:13:59 +0000 (+0200) Subject: Add support for grep and while. Inline expect_list into expect_any so that the pp... X-Git-Tag: v0.03~20 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=04997f51e7b0a73e04ef0c8df41d4ad045fc7584;p=perl%2Fmodules%2FSub-Nary.git Add support for grep and while. Inline expect_list into expect_any so that the pp's and the ops const hash are tried before the logop logic. Take all the kids handling out in expect_kids --- diff --git a/lib/Sub/Nary.pm b/lib/Sub/Nary.pm index 4e24478..0580482 100644 --- a/lib/Sub/Nary.pm +++ b/lib/Sub/Nary.pm @@ -194,6 +194,21 @@ sub combine { }} map { (ref) ? $_ : { $_ => 1 } } grep defined, @_; } +sub power { + my ($p, $n, $c) = @_; + my $s = sum values %$p; + return { 0 => $s * $c } unless $n; + if ($n eq 'list') { + my $z = delete $p->{0}; + return { 'list' => $c } unless $z; + return { 0 => $c } if $z == 1; + return { 0 => $c * $z, list => $c * ($s - $z) }; + } + my $r = combine map { { %$p } } 1 .. $n; + $r->{$_} *= $c for keys %$r; + return $r; +} + sub add { reduce { $a->{$_} += $b->{$_} for keys %$b; @@ -208,7 +223,8 @@ $ops{$_} = 0 for qw/stub nextstate/; $ops{$_} = 1 for qw/padsv/; $ops{$_} = 'list' for qw/padav/; $ops{$_} = 'list' for qw/padhv rv2hv/; -$ops{$_} = 'list' for qw/padany match entereval readline/; +$ops{$_} = 'list' for qw/padany/; +$ops{$_} = 'list' for qw/match entereval readline/; $ops{each} = { 0 => 0.5, 2 => 0.5 }; $ops{stat} = { 0 => 0.5, 13 => 0.5 }; @@ -252,7 +268,7 @@ sub enter { sub expect_return { my ($self, $op) = @_; - return ($self->expect_list($op))[0] => 1 if name($op) eq 'return'; + return ($self->expect_kids($op))[0] => 1 if name($op) eq 'return'; if ($op->flags & OPf_KIDS) { for ($op = $op->first; not null $op; $op = $op->sibling) { @@ -261,48 +277,24 @@ sub expect_return { } } - return; + return 0; } -sub expect_list { +sub expect_any { my ($self, $op) = @_; my $n = name($op); + return ($self->expect_kids($op))[0] => 1 if $n eq 'return'; + my $meth = $self->can('pp_' . $n); return $self->$meth($op) if $meth; + if (exists $ops{$n}) { my $r = $ops{$n}; - $r = { %$r } if ref $r eq 'HASH'; + $r = { %$r } if ref $r; return $r => 0; } - if ($op->flags & OPf_KIDS) { - my @res = (0); - my ($p, $r); - for ($op = $op->first; not null $op; $op = $op->sibling) { - my $n = name($op); - next if $n eq 'pushmark'; - if ($n eq 'nextstate' - and not null(($op = $op->sibling)->sibling)) { - ($p, $r) = $self->expect_return($op); - return $p => 1 if $r; - } else { - ($p, $r) = $self->expect_any($op); - return $p => 1 if $r; - push @res, $p; - } - } - return (combine @res) => 0; - } - - return; -} - -sub expect_any { - my ($self, $op) = @_; - - return ($self->expect_list($op))[0] => 1 if name($op) eq 'return'; - if (class($op) eq 'LOGOP' and not null $op->first) { my @res; my ($p, $r); @@ -326,7 +318,31 @@ sub expect_any { return (add @res) => 0; } - return $self->expect_list($op); + return $self->expect_kids($op); +} + +sub expect_kids { + my ($self, $op) = @_; + + return 0 unless $op->flags & OPf_KIDS; + + my @res = (0); + my ($p, $r); + for ($op = $op->first; not null $op; $op = $op->sibling) { + my $n = name($op); + next if $n eq 'pushmark'; + if ($n eq 'nextstate' + and not null(($op = $op->sibling)->sibling)) { + ($p, $r) = $self->expect_return($op); + return $p => 1 if $r; + } else { + ($p, $r) = $self->expect_any($op); + return $p => 1 if $r; + push @res, $p; + } + } + + return (combine @res) => 0; } # Stolen from B::Deparse @@ -451,7 +467,7 @@ sub pp_aassign { $op = $op->first; # Can't assign to return - my ($p, $r) = $self->expect_list($op->sibling); + my ($p, $r) = $self->expect_any($op->sibling); return $p => 0 if not exists $p->{list}; $self->expect_any($op); @@ -485,6 +501,41 @@ sub pp_flip { return 'list' } +sub pp_grepwhile { + my ($self, $op) = @_; + + $op = $op->first; + return 'list' if name($op) ne 'grepstart'; + + $op = $op->first->sibling; + my ($p, $r) = $self->expect_any($op); + return $p => 1 if $r; + + $op = $op->sibling; + ($p, $r) = $self->expect_any($op); + return $p => 1 if $r; + + return 'list'; +} + +sub pp_mapwhile { + my ($self, $op) = @_; + + $op = $op->first; + return 'list' if name($op) ne 'mapstart'; + + $op = $op->first->sibling; + my ($p1, $r) = $self->expect_any($op); + return $p1 => 1 if $r; + + $op = $op->sibling; + (my $p2, $r) = $self->expect_any($op); + return $p2 => 1 if $r; + $p2 = { $p2 => 1 } unless ref $p2; + + return add map { power $p1, $_, $p2->{$_} } keys %$p2; +} + =head1 EXPORT An object-oriented module shouldn't export any function, and so does this one. diff --git a/t/20-return.t b/t/20-return.t index fc63f95..ee42a98 100644 --- a/t/20-return.t +++ b/t/20-return.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 58; +use Test::More tests => 62; use Sub::Nary; @@ -80,6 +80,12 @@ my @tests = ( [ sub { return eval { do { eval { @a } } } }, 'list' ], [ sub { eval 'return 1, 2' }, 'list' ], + + [ sub { grep { return 2, 4 } 5 .. 10 }, 2 ], + [ sub { grep { $_ > 1 } do { return 2, 4; 5 .. 10 } }, 2 ], + + [ sub { map { return 2, 4 } 5 .. 10 }, 2 ], + [ sub { map { $_ + 1 } do { return 2, 4; 5 .. 10 } }, 2 ], ); my $i = 1; diff --git a/t/24-ops.t b/t/24-ops.t index f3f62f4..506b55e 100644 --- a/t/24-ops.t +++ b/t/24-ops.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 34; +use Test::More tests => 47; use Sub::Nary; @@ -11,10 +11,57 @@ my $sn = Sub::Nary->new(); my ($x, %h); +sub zeroorone { + return (rand() < 0.1) ? () : 1; +} + +sub oneortwo { + if (rand() < 0.1) { + return 3 + } else { + 4, 5 + } +} + +sub onetwothree { + my $r = rand(); + if ($r < 0.1) { + return 3 + } elsif ($r < 0.9) { + return 4, 5 + } + return 4, do { 5, 6 }; +} + +# { 1 => 0.5, 2 => 0.5 } * 0.5 + { 2 => 0.25, 3 => 0.5, 4 => 0.25 } * 0.5 +my $exp_22 = { 1 => 0.5 * 0.5, 2 => (0.5 + 0.25) * 0.5, 3 => 0.5 * 0.5, 4 => 0.25 * 0.5 }; + +# { 1 => 1/3, 2 => 1/3, 3 => 1/3 } * 0.5 + { 2 => 1/9, 3 => 2/9, 4 => 3/9, 5 => 2/9, 6 => 1/3 } * 0.5 +my $exp_32 = { 1 => 1/3/2, 2 => (1/3+1/9)/2, 3 => (1/3+2/9)/2, 4 => 3/9/2, 5 => 2/9/2, 6 => 1/3/2 }; + +my $b3 = 0.5 ** 3; +my $exp_23 = { 3 => $b3, 4 => 3 * $b3, 5 => 3 * $b3, 6 => $b3 }; + my @tests = ( [ sub { delete $h{foo} }, 1 ], [ sub { delete @h{qw/foo bar baz/} }, 3 ], + [ sub { grep { 1 } 1 .. 10 }, 'list' ], + + [ sub { map { $_ } 1 .. 3 }, 3 ], + [ sub { map { () } @_ }, 0 ], + [ sub { map { @_ } () }, 0 ], + [ sub { map { @_ } 1, 2 }, 'list' ], + [ sub { map { $_ } oneortwo() }, { 1 => 0.5, 2 => 0.5 } ], + [ sub { map { $_ ? 7 : (8, 9) } 1 .. 3 }, $exp_23 ], + [ sub { map oneortwo, 1 .. 3 }, $exp_23 ], + [ sub { map oneortwo, @_ }, 'list' ], + [ sub { map zeroorone, @_ }, { 0 => 0.5, list => 0.5 } ], + [ sub { map { $_ ? () : 12 } do { $x ? 7 : () } }, { 0 => 0.75, 1 => 0.25 } ], + [ sub { map zeroorone, do { $x ? 7 : () } }, { 0 => 0.75, 1 => 0.25 } ], + [ sub { map oneortwo, oneortwo }, $exp_22 ], + [ sub { map onetwothree, oneortwo }, $exp_32 ], + [ sub { return <$x> }, 'list' ], [ sub { -f $0, -r $0 }, 2 ], diff --git a/t/92-pod-coverage.t b/t/92-pod-coverage.t index 6c79b70..923a391 100644 --- a/t/92-pod-coverage.t +++ b/t/92-pod-coverage.t @@ -15,4 +15,4 @@ 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/^expect_/, qw/add combine const_sv enter gv_or_padgv name null padval scalops tag/ ] }); +all_pod_coverage_ok({ also_private => [ qr/^pp_/, qr/^expect_/, qw/add combine power const_sv enter gv_or_padgv name null padval scalops tag/ ] });