X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FSub%2FNary.pm;h=313381f435686db10599dac7f30b7e621e031be3;hb=2eb7d799fbc08f3dbeada52aeac89c781983e081;hp=b6ad798ebbe50604af0198ef7d183e8ebb90e5f2;hpb=f73405816c83f0e2816e81421a8b6cf72d5e3151;p=perl%2Fmodules%2FSub-Nary.git diff --git a/lib/Sub/Nary.pm b/lib/Sub/Nary.pm index b6ad798..313381f 100644 --- a/lib/Sub/Nary.pm +++ b/lib/Sub/Nary.pm @@ -9,25 +9,21 @@ use Carp qw/croak/; 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; @@ -47,9 +43,23 @@ The usual constructor. Currently takes no argument. =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 +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. A few special keys are also used : + +=over 4 + +=item * + +C<'list'> is used to denote a possibly infinite number of returned arguments ; + +=item * + +C<'exit'> gives the probability for C to be called somewhere in the code. + +=back + +The return value hence would look at - { 1 => 0.2, 2 => 0.4, 4 => 0.3, list => 0.1 } + { 1 => 0.2, 2 => 0.4, 4 => 0.25, list => 0.1, exit => 0.05 } 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. @@ -63,7 +73,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 @@ -89,7 +101,9 @@ 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 * + +The total probability law for a given returning point is the convolution product of the probabilities of its list elements. As such, @@ -105,13 +119,17 @@ 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 } >>. -=item * The C state is absorbing in regard of all the other ones. +=item * -This is just a pedantic way to say that "list + fixed length = list". +The C and C states are absorbing in regard of all the other ones. + +This is just a pedantic way to say that C, C, but note also that C. That's why sub listy { @@ -120,7 +138,7 @@ That's why is considered as always returning an unbounded list. -Also, the convolution law does not behave the same when C elements are involved : in the following example, +Also, the convolution law does not behave the same when C or C elements are involved : in the following example, sub oneorlist { if (rand < 0.1) { @@ -195,7 +213,7 @@ sub power { my %ops; $ops{$_} = 1 for scalops; -$ops{$_} = 0 for qw/stub nextstate pushmark iter unstack/; +$ops{$_} = 0 for qw/stub nextstate iter unstack/; $ops{$_} = 1 for qw/padsv/; $ops{$_} = 'list' for qw/padav/; $ops{$_} = 'list' for qw/padhv rv2hv/; @@ -216,11 +234,33 @@ $ops{$_} = { 0 => 0.5, 4 => 0.5 } for qw/gnbyname gnbyaddr gnetent/; $ops{$_} = { 0 => 0.5, 3 => 0.5 } for qw/gpbyname gpbynumber gprotoent/; $ops{$_} = { 0 => 0.5, 4 => 0.5 } for qw/gsbyname gsbyport gservent/; +# Stolen from B::Deparse + +sub padval { $_[0]->{cv}->[0]->PADLIST->ARRAYelt(1)->ARRAYelt($_[1]) } + +sub gv_or_padgv { + my ($self, $op) = @_; + if (class($op) eq 'PADOP') { + return $self->padval($op->padix) + } else { # class($op) eq "SVOP" + return $op->gv; + } +} + +sub const_sv { + my ($self, $op) = @_; + my $sv = $op->sv; + # the constant could be in the pad (under useithreads) + $sv = $self->padval($op->targ) unless $$sv; + return $sv; +} + sub enter { my ($self, $cv) = @_; return undef, 'list' if class($cv) ne 'CV'; my $op = $cv->ROOT; + return undef, 'list' if null $op; my $tag = tag($op); return undef, { %{$self->{cache}->{$tag}} } if exists $self->{cache}->{$tag}; @@ -234,62 +274,95 @@ 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; } +use Test::More; +use Data::Dumper; + 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); return $self->$meth($op) if $meth; + my $l; if (exists $ops{$n}) { - my $l = $ops{$n}; + $l = $ops{$n}; $l = { %$l } if ref $l; - return undef, $l; } - if (class($op) eq 'LOGOP' and not null $op->first) { - my @res; + my $c = class($op); + $meth = $self->can('OPc_' . $c); + if ($meth) { + my ($r, $lc) = $self->$meth($op); + $lc = $l if defined $l; + return $r, $lc; + } - diag "? logop\n" if $DEBUG; + return undef, (defined $l) ? $l : 0; +} - my $op = $op->first; - my ($r1, $l1) = $self->inspect($op); - return $r1, $l1 if $r1 and zero $l1; - my $c = count $l1; +# UNOPs - $op = $op->sibling; - my ($r2, $l2) = $self->inspect($op); +sub OPc_UNOP { $_[0]->inspect($_[1]->first); } - $op = $op->sibling; - my ($r3, $l3); - if (null $op) { - # If the logop has no else branch, it can also return the *scalar* result of - # the conditional - $l3 = { 1 => 1 }; - } else { - ($r3, $l3) = $self->inspect($op); - } +# BINOPs - my $r = add $r1, scale $c / 2, add $r2, $r3; - my $l = scale $c / 2, add $l2, $l3; - return $r, $l - } +sub OPc_BINOP { + my ($self, $op) = @_; + + my ($r, $l1) = $self->inspect($op->first); + return $r, $l1 unless defined $l1; + + my ($r2, $l2) = $self->inspect($op->last); + my $c = 1 - count $r; + $r = add $r, scale $c, $r2 if defined $r2; + + my $l = scale +(1 - count $r), normalize combine $l1, $l2; - return $self->inspect_kids($op); + return $r, $l; } -sub inspect_kids { +# LOGOPs + +sub OPc_LOGOP { my ($self, $op) = @_; + my @res; - return undef, 0 unless $op->flags & OPf_KIDS; + $op = $op->first; + return undef, 0 if null $op; + + my ($r1, $l1) = $self->inspect($op); + return $r1, $l1 if defined $r1 and zero $l1; + my $c = count $l1; + + $op = $op->sibling; + my ($r2, $l2) = $self->inspect($op); + + $op = $op->sibling; + my ($r3, $l3); + if (null $op) { + # If the logop has no else branch, it can also return the *scalar* result of + # the conditional + $l3 = { 1 => 1 }; + } else { + ($r3, $l3) = $self->inspect($op); + } + + my $r = add $r1, scale $c / 2, add $r2, $r3; + my $l = scale $c / 2, add $l2, $l3; + return $r, $l; + + return $self->OPc_LISTOP($op); +} + +# LISTOPs + +sub OPc_LISTOP { + my ($self, $op) = @_; $op = $op->first; return undef, 0 if null $op; @@ -311,10 +384,8 @@ sub inspect_kids { $op = $op->first; redo; } - 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 (not defined $lc) { @l = (); @@ -323,55 +394,27 @@ sub inspect_kids { push @l, scale $c, $lc; } -# diag Dumper \@l if $DEBUG; my $l = scale +(1 - count $r), normalize combine @l; return $r, $l; } -# Stolen from B::Deparse - -sub padval { $_[0]->{cv}->[0]->PADLIST->ARRAYelt(1)->ARRAYelt($_[1]) } - -sub gv_or_padgv { - my ($self, $op) = @_; - if (class($op) eq 'PADOP') { - return $self->padval($op->padix) - } else { # class($op) eq "SVOP" - return $op->gv; - } -} - -sub const_sv { - my ($self, $op) = @_; - my $sv = $op->sv; - # the constant could be in the pad (under useithreads) - $sv = $self->padval($op->targ) unless $$sv; - return $sv; -} +sub pp_return { add($_[0]->OPc_LISTOP($_[1])), undef } 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; } @@ -385,8 +428,8 @@ sub pp_entersub { $next = $next->sibling; } $n = name($op) - } while ($op->flags & OPf_KIDS and { map { $_ => 1 } qw/null leave/ }->{$n}); - return 'list', undef unless { map { $_ => 1 } qw/gv refgen/ }->{$n}; + } while $op->flags & OPf_KIDS and ($n eq 'null' or $n eq 'leave'); + return 'list', undef unless $n eq 'gv' or $n eq 'refgen'; local $self->{sub} = 1; my ($rc, $lc) = $self->inspect($op); return $r, scale $c, $lc; @@ -408,6 +451,35 @@ sub pp_anoncode { return $self->{sub} ? $self->enter($self->const_sv($op)) : (undef, 1) } +sub pp_exit { + my ($self, $op) = @_; + + my $r; + if ($op->flags & OPf_KIDS) { + ($r, my $l) = $self->inspect($op->first); + return $r, $l if defined $r and zero $l; + $r->{exit} = 1 - count $r; + } else { + $r = { 'exit' => 1 }; + } + + return $r, undef; +} + +sub pp_die { + my ($self, $op) = @_; + + my ($r, undef) = $self->OPc_LISTOP($op); + if (defined $r) { + my $c = 1 - count $r; + $r->{die} = $c if $c; + } else { + $r = { die => 1 }; + } + + return $r, undef; +} + sub pp_goto { my ($self, $op) = @_; @@ -440,7 +512,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 @@ -457,14 +529,24 @@ 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 } +=cut + sub pp_aassign { my ($self, $op) = @_; @@ -477,30 +559,57 @@ sub pp_aassign { $self->inspect($op); } -sub pp_leaveloop { +=cut + +sub pp_leavetry { my ($self, $op) = @_; - diag "* leaveloop" if $DEBUG; + my ($r, $l) = $self->OPc_LISTOP($op); + if (defined $r) { + my $d = delete $r->{die}; + return $r, $l if not defined $d; + if (defined $l) { + my $z = delete $l->{0}; + $l = { %$l, 0 => $z }; + $l->{0} += $d; + } else { + $l = { 0 => $d }; + } + } + + return $r, $l; +} + +sub pp_leaveloop { + my ($self, $op) = @_; $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; + my ($r2, $l2); 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]; + ($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 { - $r = ($self->inspect($op))[0]; + ($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 $c" if $DEBUG; return $r, $c ? { 0 => $c } : undef; } @@ -542,12 +651,12 @@ sub pp_grepwhile { $op = $op->first->sibling; my ($r2, $l2) = $self->inspect($op->sibling); - return $r2, $l2 if $r2 and zero $l2; + 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 $c2, $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; @@ -566,12 +675,12 @@ sub pp_mapwhile { $op = $op->first->sibling; my ($r2, $l2) = $self->inspect($op->sibling); - return $r2, $l2 if $r2 and zero $l2; + 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 $c2, $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; @@ -603,11 +712,11 @@ L (standard since perl 5), L (since perl 5.005) and L (since 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