From: Vincent Pit Date: Wed, 20 Aug 2008 21:03:58 +0000 (+0200) Subject: Add support for exit(). Simplify combine() so that it can handle exit/list interaction X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=abc14695a4ce4fd4733c9185d87b774ee7c1a220;p=perl%2Fmodules%2FSub-Nary.git Add support for exit(). Simplify combine() so that it can handle exit/list interaction --- diff --git a/MANIFEST b/MANIFEST index a6d62d3..cb97b5c 100644 --- a/MANIFEST +++ b/MANIFEST @@ -17,6 +17,7 @@ t/22-call.t t/23-branch.t t/24-ops.t t/25-grepmap.t +t/26-exit.t t/90-boilerplate.t t/91-pod.t t/92-pod-coverage.t diff --git a/Nary.xs b/Nary.xs index 285bfc3..0329eea 100644 --- a/Nary.xs +++ b/Nary.xs @@ -6,6 +6,10 @@ #include "perl.h" #include "XSUB.h" +#ifndef Newx +# define Newx(v, n, c) New(0, v, n, c) +#endif + #ifndef mPUSHi # define mPUSHi(I) PUSHs(sv_2mortal(newSViv(I))) #endif /* !mPUSHi */ @@ -25,8 +29,8 @@ STATIC void sn_store_ent(pTHX_ HV *tb, SV *key, SV *val, U32 hash) { if (!hv_store_ent(tb, key, val, hash)) SvREFCNT_dec(val); } - STATIC U32 sn_hash_list = 0; +STATIC U32 sn_hash_exit = 0; /* --- XS ------------------------------------------------------------------ */ @@ -37,6 +41,7 @@ PROTOTYPES: ENABLE BOOT: { PERL_HASH(sn_hash_list, "list", 4); + PERL_HASH(sn_hash_exit, "exit", 4); } void @@ -241,95 +246,83 @@ void combine(...) PROTOTYPE: @ PREINIT: - HV *res[2]; - SV *cur, *val; - SV *list1, *list2; + HV *res[3]; + SV *val; + SV *exit1, *list1; SV *temp; HE *key, *old; I32 i; I32 n = 0, o; I32 j, n1, n2; - UV shift = 0, do_shift = 0; + NV pl = 0, pe = 0; sn_combcache *cache = NULL; - I32 cachelen = 0; + I32 cachelen = 1; CODE: if (!items) XSRETURN_UNDEF; - res[0] = res[1] = NULL; - for (i = 0; i < items; ++i) { - cur = ST(i); - if (!SvOK(cur)) - continue; - if (!SvROK(cur)) { - if (strEQ(SvPV_nolen(cur), "list")) { - res[0] = newHV(); - n = 0; - sn_store(res[0], "list", 4, newSVuv(1), sn_hash_list); - i = items; - if (!shift) - do_shift = 0; - break; - } else { - shift += SvUV(cur); - do_shift = 1; - continue; - } - } - cur = SvRV(cur); - res[0] = newHV(); - while (key = hv_iternext((HV *) cur)) - sn_store_ent(res[0], HeSVKEY_force(key), newSVsv(HeVAL(key)), 0); - n = 0; - if (!shift) - do_shift = 0; - break; - } + res[0] = newHV(); + res[1] = NULL; + res[2] = NULL; + Newx(cache, 1, sn_combcache); + n = 0; temp = sv_2mortal(newSViv(0)); - for (++i; i < items; ++i) { - cur = ST(i); + for (i = 0; i < items; ++i) { + SV *cur = ST(i); + NV pe1 = 0, pl1 = 0; if (!SvOK(cur)) continue; if (!SvROK(cur)) { - if (strEQ(SvPV_nolen(cur), "list")) { - hv_clear(res[n]); - sn_store(res[n], "list", 4, newSVuv(1), sn_hash_list); - shift = 0; - do_shift = 0; - break; - } else { - shift += SvUV(cur); - continue; - } - } - cur = SvRV(cur); - o = 1 - n; + if (!res[2]) + res[2] = newHV(); + else + hv_clear(res[2]); + sn_store_ent(res[2], cur, newSVuv(1), 0); + cur = (SV *) res[2]; + } else + cur = SvRV(cur); + o = 1 - n; if (!res[o]) res[o] = newHV(); else hv_clear(res[o]); - list1 = hv_delete((HV *) cur, "list", 4, 0); + exit1 = hv_delete((HV *) cur, "exit", 4, 0); n1 = hv_iterinit((HV *) cur); - list2 = hv_delete(res[n], "list", 4, 0); - n2 = hv_iterinit(res[n]); - if ((list1 && !n1) || (list2 && !n2)) { - sn_store(res[o], "list", 4, newSViv(1), sn_hash_list); - n = o; - break; - } else if (list1 || list2) { - NV l1 = list1 ? SvNV(list1) : 0; - NV l2 = list2 ? SvNV(list2) : 0; - val = newSVnv(l1 + l2 - l1 * l2); - sn_store(res[o], "list", 4, val, sn_hash_list); + if (exit1) { + if (!n1) { + pe = 1; + pl = 0; + n = o; + break; + } + pe1 = SvNV(exit1); } - if (n2 > cachelen) { - Renew(cache, n2, sn_combcache); - cachelen = n2; + list1 = hv_delete((HV *) cur, "list", 4, 0); + if (list1) { + if (n1 == 1) { + pl = 1 - pe; + n = o; + break; + } + pl1 = SvNV(list1); } - j = 0; - while (key = hv_iternext(res[n])) { - cache[j].k = SvUV(HeSVKEY_force(key)); - cache[j].v = SvNV(HeVAL(key)); - ++j; + pl = pl1 * (1 - pe) + pl * (1 - pe1) - pl * pl1; + pe = pe + (1 - pe) * pe1; + n2 = hv_iterinit(res[n]); + if (!n2) { + cache[0].k = 0; + cache[0].v = 1; + n2 = 1; + } else { + if (n2 > cachelen) { + Renew(cache, n2, sn_combcache); + cachelen = n2; + } + j = 0; + while (key = hv_iternext(res[n])) { + cache[j].k = SvUV(HeSVKEY_force(key)); + cache[j].v = SvNV(HeVAL(key)); + ++j; + } } while (key = hv_iternext((HV *) cur)) { IV k = SvUV(HeSVKEY_force(key)); @@ -347,35 +340,22 @@ CODE: n = o; } Safefree(cache); - if (shift || do_shift) { - if (!res[n]) { - res[n] = newHV(); - sv_setiv(temp, shift); - sn_store_ent(res[n], temp, newSViv(1), 0); - } else { - o = 1 - n; - if (!res[o]) - res[o] = newHV(); - else - hv_clear(res[o]); - list1 = hv_delete(res[n], "list", 4, 0); - hv_iterinit(res[n]); - while (key = hv_iternext(res[n])) { - sv_setiv(temp, SvUV(HeSVKEY_force(key)) + shift); - sn_store_ent(res[o], temp, newSVsv(HeVAL(key)), 0); - } - if (list1) - sn_store(res[o], "list", 4, newSVsv(list1), sn_hash_list); - n = o; - } - } else if (!res[0] && !res[1]) - XSRETURN_UNDEF; + SvREFCNT_dec(res[2]); + if (pe) + sn_store(res[n], "exit", 4, newSVnv(pe), sn_hash_exit); + if (pl) + sn_store(res[n], "list", 4, newSVnv(pl), sn_hash_list); if (n == 1) SvREFCNT_dec(res[0]); else if (res[1]) SvREFCNT_dec(res[1]); - ST(0) = sv_2mortal(newRV_noinc((SV *) res[n])); - XSRETURN(1); + if (!hv_iterinit(res[n])) { + SvREFCNT_dec(res[n]); + XSRETURN_UNDEF; + } else { + ST(0) = sv_2mortal(newRV_noinc((SV *) res[n])); + XSRETURN(1); + } void scalops() diff --git a/lib/Sub/Nary.pm b/lib/Sub/Nary.pm index 1406d66..73345b5 100644 --- a/lib/Sub/Nary.pm +++ b/lib/Sub/Nary.pm @@ -43,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 : - { 1 => 0.2, 2 => 0.4, 4 => 0.3, list => 0.1 } +=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.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. @@ -105,9 +119,9 @@ never returns C<1> argument but returns C<2> with probability C<1/2 * 1/2 = 1/4> 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 * The C and C states are absorbing in regard of all the other ones. -This is just a pedantic way to say that "list + fixed length = list". +This is just a pedantic way to say that C, C, but note also that C. That's why sub listy { @@ -116,7 +130,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) { @@ -389,6 +403,21 @@ 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_goto { my ($self, $op) = @_; diff --git a/t/15-misc-xs.t b/t/15-misc-xs.t index c9ac01d..42847e6 100644 --- a/t/15-misc-xs.t +++ b/t/15-misc-xs.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 32; +use Test::More tests => 20; use Sub::Nary; @@ -47,26 +47,3 @@ is_deeply(cumulate({ 1 => 0.5, 2 => 0.5 }, 1, 0.5), { 1 => 0.5, 2 => 0.5 }, 'cumulate ref, 1, frac'); is_deeply(cumulate({ 1 => 0.5, 2 => 0.5 }, 2, 0.5), { 1 => 0.75, 2 => 0.75 }, 'cumulate ref, 1, frac'); - -*combine = *Sub::Nary::combine{CODE}; - -is_deeply(combine(undef), undef, 'combine undef'); -is_deeply(combine({}), {}, 'combine empty-ref'); -is_deeply(combine({}, {}), {}, 'combine empty-ref, empty-ref'); -is_deeply(combine(1), { 1 => 1 }, 'combine const'); -is_deeply(combine(1, 2), { 3 => 1 }, 'combine const, const'); -is_deeply(combine(1, 'list'), { 'list' => 1 }, 'combine const, list'); -is_deeply(combine(1,{'list'=>1}), { 'list' => 1 }, 'combine const, list'); -is_deeply(combine(1, { 1 => 0.5, 2 => 0.5 }), { 2 => 0.5, 3 => 0.5 }, - 'combine const, hashref'); -is_deeply(combine(1, { 1 => 0.5, 'list' => 0.5 }), { 2 => 0.5, 'list' => 0.5 }, - 'combine const, hashref with list'); -my $x = { 1 => 0.5, 2 => 0.5 }; -is_deeply(combine($x, $x), { 2 => 0.25, 3 => 0.5, 4 => 0.25 }, - 'combine hashref, hashref'); -is_deeply(combine($x, 'list', $x), { list => 1 }, - 'combine hashref, list, hashref'); -$x = { 1 => 0.5, list => 0.5 }; -is_deeply(combine($x, $x), { 2 => 0.25, list => 0.75 }, - 'combine hashref with list, hashref with list'); - diff --git a/t/16-combine.t b/t/16-combine.t index 03b8386..7f0b459 100644 --- a/t/16-combine.t +++ b/t/16-combine.t @@ -3,17 +3,22 @@ use strict; use warnings; -use Test::More tests => 24; +use Test::More tests => 41; use Sub::Nary; *combine = *Sub::Nary::combine{CODE}; my $h12 = { 1 => 0.5, 2 => 0.5 }; +my $h1l = { 1 => 0.5, list => 0.5 }; +my $h1e = { 1 => 0.5, exit => 0.5 }; +my $h1le = { 1 => 0.25, list => 0.25, exit => 0.5 }; my @tests = ( - [ [ ], undef ], - [ [ undef ], undef ], + [ [ ], undef ], + [ [ undef ], undef ], + [ [ { } ], undef ], + [ [ { }, { } ], undef ], [ [ 0 ], 0 ], [ [ 1, undef ], 1 ], @@ -22,24 +27,42 @@ my @tests = ( [ [ 1, 2 ], 3 ], [ [ 2, undef, 3 ], 5 ], - [ [ 'list' ], 'list' ], - [ [ 0, 'list' ], 'list' ], - [ [ 1, 'list' ], 'list' ], - [ [ 1, undef, 'list' ], 'list' ], - [ [ 1, 'list', 2 ], 'list' ], + [ [ 'list' ], 'list' ], + [ [ { 'list' => 1 } ], 'list' ], + [ [ 0, 'list' ], 'list' ], + [ [ 1, 'list' ], 'list' ], + [ [ 1, { 'list' => 1 } ], 'list' ], + [ [ 1, undef, 'list' ], 'list' ], + [ [ 1, 'list', 2 ], 'list' ], - [ [ $h12 ], $h12 ], - [ [ 1, $h12 ], { 2 => 0.5, 3 => 0.5 } ], - [ [ $h12, 2 ], { 3 => 0.5, 4 => 0.5 } ], - [ [ $h12, undef, 3 ], { 4 => 0.5, 5 => 0.5 } ], - [ [ $h12, 'list' ], 'list' ], - [ [ $h12, 3, 'list' ], 'list' ], - [ [ 1, 0, $h12, 2, 0 ], { 4 => 0.5, 5 => 0.5 } ], + [ [ $h12 ], $h12 ], + [ [ 1, $h12 ], { 2 => 0.5, 3 => 0.5 } ], + [ [ $h12, 2 ], { 3 => 0.5, 4 => 0.5 } ], + [ [ $h12, undef, 3 ], { 4 => 0.5, 5 => 0.5 } ], + [ [ $h12, 'list' ], 'list' ], + [ [ $h12, 3, 'list' ], 'list' ], + [ [ $h12, 'list', $h12 ], 'list' ], + [ [ 1, 0, $h12, 2, 0 ], { 4 => 0.5, 5 => 0.5 } ], [ [ $h12, $h12 ], { 2 => 0.25, 3 => 0.5, 4 => 0.25 } ], [ [ 1, $h12, $h12 ], { 3 => 0.25, 4 => 0.5, 5 => 0.25 } ], [ [ $h12, 2, $h12 ], { 4 => 0.25, 5 => 0.5, 6 => 0.25 } ], [ [ $h12, $h12, 3 ], { 5 => 0.25, 6 => 0.5, 7 => 0.25 } ], + + [ [ 1, { %$h1l } ], { 2 => 0.5, 'list' => 0.5 } ], + [ [ { %$h1l }, { %$h1l } ], { 2 => 0.25, list => 0.75 } ], + [ [ { %$h1l }, 1, { %$h1l } ], { 3 => 0.25, list => 0.75 } ], + + [ [ 'exit' ], 'exit' ], + [ [ 'exit', 1 ], 'exit' ], + [ [ { %$h1e }, 1 ], { exit => 0.5, 2 => 0.5 } ], + [ [ { %$h1e }, { %$h1e } ], { exit => 0.75, 2 => 0.25 } ], + [ [ { %$h1e }, { %$h1l } ], { exit => 0.5, list => 0.25, 2 => 0.25 } ], + [ [ { %$h1l }, { %$h1e } ], { exit => 0.5, list => 0.25, 2 => 0.25 } ], + [ [ { %$h1l }, { %$h1le } ], { exit => 0.5, list => 0.375, 2 => 0.125 } ], + [ [ { %$h1e }, { %$h1le } ], { exit => 0.75, list => 0.125, 2 => 0.125 } ], + + [ [ $h1l, $h1l ], { 2 => 0.25, list => 0.5 } ], # Side effects ); my $i = 1; diff --git a/t/26-exit.t b/t/26-exit.t new file mode 100644 index 0000000..9cd28a1 --- /dev/null +++ b/t/26-exit.t @@ -0,0 +1,43 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 9; + +use Sub::Nary; + +my $sn = Sub::Nary->new(); + +my ($x, $y); + +sub exits { + if ($x) { + exit do { return 3, 4 if $y } + } + @_[0 .. 2]; +} + +my @tests = ( + [ sub { exit }, { exit => 1 } ], + [ sub { exit 1 }, { exit => 1 } ], + [ sub { if ($x) { exit } }, { exit => 0.5, 1 => 0.5 } ], + [ sub { if (exit) { return 1, 2 } }, { exit => 1 } ], + [ sub { exit do { return 3, 4 } }, { 2 => 1 } ], + [ sub { $x ? exit($y ? exit : return(2, 3)) : 4 }, + { exit => 0.25, 2 => 0.25, 1 => 0.5 } ], + + [ \&exits, { exit => 0.25, 2 => 0.25, 3 => 0.5 } ], + [ sub { exits(), do { $x ? @_ : 1 } }, { exit => 0.25, 3 => 0.125, 4 => 0.25, + list => (0.25 + 0.5) * 0.5 } ], + [ sub { exits(), 1, do { $x ? @_ : 1 } }, + { exit => 0.25, 4 => 0.125, 5 => 0.25, list => (0.25 + 0.5) * 0.5 } ], +); + +my $i = 1; +for (@tests) { + my $r = $sn->nary($_->[0]); + my $exp = ref $_->[1] ? $_->[1] : { $_->[1] => 1 }; + is_deeply($r, $exp, 'exit test ' . $i); + ++$i; +}