X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FSub%2FNary.pm;h=ec8ca4d02c9a26389c71e8706e441850b11b6237;hb=37cafd97ccbd41d9cde225a53f6a058ac23ce7d5;hp=f21c8f81446aa64aff112b2f49f22bfb7fa47939;hpb=91deeda20173f3d35c5b936c9e6db1cbe08f0e00;p=perl%2Fmodules%2FSub-Nary.git diff --git a/lib/Sub/Nary.pm b/lib/Sub/Nary.pm index f21c8f8..ec8ca4d 100644 --- a/lib/Sub/Nary.pm +++ b/lib/Sub/Nary.pm @@ -1,62 +1,68 @@ package Sub::Nary; -use 5.008001; +use 5.008_001; use strict; use warnings; use Carp qw/croak/; -use List::Util qw/reduce/; use B qw/class ppname svref_2object OPf_KIDS/; -use Test::More; use Data::Dumper; - =head1 NAME Sub::Nary - Try to count how many elements a subroutine can return in list context. =head1 VERSION -Version 0.02 +Version 0.03 =cut our $VERSION; BEGIN { - $VERSION = '0.02'; + $VERSION = '0.03'; } -our $DEBUG = 0; - =head1 SYNOPSIS use Sub::Nary; - my $sn = Sub::Nary->new(); + my $sn = Sub::Nary->new; my $r = $sn->nary(\&hlagh); =head1 DESCRIPTION -This module uses the L framework to walk into subroutines and try to guess how many scalars are likely to be returned in list context. It's not always possible to give a definitive answer to this question at compile time, so the results are given in terms of "probability of return" (to be understood in a sense described below). +This module uses the L framework to walk into subroutines and try to guess how many scalars are likely to be returned in list context. +It's not always possible to give a definitive answer to this question at compile time, so the results are given in terms of "probability of return" (to be understood in a sense described below). =head1 METHODS =head2 C -The usual constructor. Currently takes no argument. + my $sn = Sub::Nary->new; + +The usual constructor. +Currently takes no argument. -=head2 C +=head2 C -Takes a code reference to a named or anonymous subroutine, and returns a hash reference whose keys are the possible numbers of returning scalars, and the corresponding values the "probability" to get them. The special key C<'list'> is used to denote a possibly infinite number of returned arguments. The return value hence would look at + my $res = $sn->nary($coderef); + +Takes a reference to a named or anonymous subroutine, and returns a hash reference whose keys are the possible numbers of returning scalars, and the corresponding values the "probability" to get them. +The special key C<'list'> is used to denote a possibly infinite number of returned arguments. +The return value hence would look at { 1 => 0.2, 2 => 0.4, 4 => 0.3, list => 0.1 } -that is, we should get C<1> scalar C<1> time over C<5> and so on. The sum of all values is C<1>. The returned result, and all the results obtained from intermediate subs, are cached into the object. +that is, we should get C<1> scalar C<1> time over C<5> and so on. +The sum of all values is C<1>. +The returned result, and all the results obtained from intermediate subs, are cached into the object. =head2 C -Flushes the L object cache. Returns the object itself. +Flushes the L object cache. +Returns the object itself. =head1 PROBABILITY OF RETURN @@ -64,7 +70,9 @@ The probability is computed as such : =over 4 -=item * When branching, each branch is considered equally possible. +=item * + +When branching, each branch is considered equally possible. For example, the subroutine @@ -90,9 +98,11 @@ As for it is considered to return C<3> scalars with probability C<1/2>, C<2> with probability C<1/2 * 1/2 = 1/4> and C<1> (when the two tests fail, the last computed value is returned, which here is C<< $x > 0.9 >> evaluated in the scalar context of the test) with remaining probability C<1/4>. -=item * The total probability law for a given returning point is the convolution product of the probabilities of its list elements. +=item * -As such, +The total probability law for a given returning point is the convolution product of the probabilities of its list elements. + +As such, sub notsosimple { return 1, simple(), 2 @@ -106,11 +116,16 @@ returns C<3> or C<4> arguments with probability C<1/2> ; and never returns C<1> argument but returns C<2> with probability C<1/2 * 1/2 = 1/4>, C<3> with probability C<1/2 * 1/2 + 1/2 * 1/2 = 1/2> and C<4> with probability C<1/4> too. -=item * If a core function may return different numbers of scalars, each kind is considered equally possible. +=item * + +If a core function may return different numbers of scalars, each kind is considered equally possible. + +For example, C returns C<13> elements on success and C<0> on error. +The according probability will then be C<< { 0 => 0.5, 13 => 0.5 } >>. -For example, C returns C<13> elements on success and C<0> on error. The according probability will then be C<< { 0 => 0.5, 13 => 0.5 } >>. +=item * -=item * The C state is absorbing in regard of all the other ones. +The C state is absorbing in regard of all the other ones. This is just a pedantic way to say that "list + fixed length = list". That's why @@ -178,12 +193,6 @@ sub name ($) { $n eq 'null' ? substr(ppname($_[0]->targ), 3) : $n } -sub scale { - my ($c, $r) = @_; - return unless defined $r; - return (ref $r) ? { map { $_ => $r->{$_} * $c } keys %$r } : { $r => $c }; -} - sub power { my ($p, $n, $c) = @_; return unless defined $p; @@ -199,13 +208,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; @@ -248,7 +250,6 @@ sub enter { my $r = add $self->inspect($op->first); shift @{$self->{cv}}; - $r = { $r => 1 } unless ref $r; $self->{cache}->{$tag} = { %$r }; return undef, $r; } @@ -257,7 +258,6 @@ sub inspect { my ($self, $op) = @_; my $n = name($op); - diag "@ $n" if $DEBUG; return add($self->inspect_kids($op)), undef if $n eq 'return'; my $meth = $self->can('pp_' . $n); @@ -272,11 +272,9 @@ sub inspect { if (class($op) eq 'LOGOP' and not null $op->first) { my @res; - diag "? logop\n" if $DEBUG; - my $op = $op->first; my ($r1, $l1) = $self->inspect($op); - return $r1, $l1 if $r1 and zero $l1; + return $r1, $l1 if defined $r1 and zero $l1; my $c = count $l1; $op = $op->sibling; @@ -287,7 +285,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); } @@ -325,18 +323,17 @@ sub inspect_kids { $op = $op->first; redo; } - diag "> $n ($c)" if $DEBUG; my ($rc, $lc) = $self->inspect($op); + $c = 1 - count $r; $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; + my $l = scale +(1 - count $r), normalize combine @l; return $r, $l; } @@ -366,24 +363,16 @@ sub pp_entersub { my ($self, $op) = @_; $op = $op->first while $op->flags & OPf_KIDS; - return undef, 0 if null $op; - if (name($op) eq 'pushmark') { - $op = $op->sibling; - return undef, 0 if null $op; - } + # First must be a pushmark + $op = $op->sibling; + # Next must be non null - at worse it's the rv2cv my $r; my $c = 1; for (; not null $op->sibling; $op = $op->sibling) { - my $n = name($op); - next if $n eq 'nextstate'; - diag "* $n" if $DEBUG; my ($rc, $lc) = $self->inspect($op); - $r = add $r, scale $c, $rc if defined $rc; - if (zero $lc) { - $c = 1 - count $r; - return $r, $c ? { 0 => $c } : undef - } + return $rc, $lc if defined $rc and not defined $lc; + $r = add $r, scale $c, $rc; $c *= count $lc; } @@ -452,7 +441,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 @@ -469,12 +458,20 @@ sub pp_rv2av { my ($self, $op) = @_; $op = $op->first; - my ($r, $l) = $self->inspect($op); - if (name($op) ne 'const') { - my $c = 1 - count $r; - $l = $c ? { list => $c } : 0; + if (name($op) eq 'gv') { + return undef, { list => 1 }; } - return $r, $l; + + $self->inspect($op); +} + +sub pp_sassign { + my ($self, $op) = @_; + + my $r = ($self->inspect($op->first))[0]; + + my $c = 1 - count $r; + return $r, $c ? { 1 => $c } : undef } sub pp_aassign { @@ -492,20 +489,33 @@ sub pp_aassign { sub pp_leaveloop { my ($self, $op) = @_; - diag "* leaveloop" if $DEBUG; - $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; return $r, $c ? { 0 => $c } : undef; } @@ -536,7 +546,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 { @@ -547,20 +557,19 @@ sub pp_grepwhile { $op = $op->first->sibling; 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 + return $r2, $l2 if defined $r2 and zero $l2; + 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 defined $r1 and zero $l1 + and not zero $l2; + 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; } @@ -572,18 +581,19 @@ sub pp_mapwhile { $op = $op->first->sibling; my ($r2, $l2) = $self->inspect($op->sibling); - return $r2, $l2 if $r2 and zero $l2; - my $c = count $l2; # First one to happen + return $r2, $l2 if defined $r2 and zero $l2; + 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; - diag Dumper [ [ $r1, $l1 ], [ $r2, $l2 ] ] if $DEBUG; + return (add $r2, scale $c2, $r1), undef if defined $r1 and zero $l1 + and not zero $l2; + 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; } @@ -602,17 +612,21 @@ C isn't specialized when encountered in the optree. L 5.8.1. -L (standard since perl 5), L (since perl 5.005), L (since perl 5.006) and L (since perl 5.007003). +A C compiler. +This module may happen to build with a C++ compiler as well, but don't rely on it, as no guarantee is made in this regard. + +L (standard since perl 5), L (since perl 5.005) and L (since perl 5.6.0). =head1 AUTHOR Vincent Pit, C<< >>, L. -You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince). +You can contact me by mail or on C (vincent). =head1 BUGS -Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. +Please report any bugs or feature requests to C, or through the web interface at L. +I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT