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
#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 */
if (!hv_store_ent(tb, key, val, hash)) SvREFCNT_dec(val);
}
-
STATIC U32 sn_hash_list = 0;
+STATIC U32 sn_hash_exit = 0;
/* --- XS ------------------------------------------------------------------ */
BOOT:
{
PERL_HASH(sn_hash_list, "list", 4);
+ PERL_HASH(sn_hash_exit, "exit", 4);
}
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));
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()
=head2 C<nary $coderef>
-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<exit> 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.
For example, C<stat> 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<list> state is absorbing in regard of all the other ones.
+=item * The C<list> and C<exit> 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<list + fixed length = list>, C<exit + fixed length = exit>, but note also that C<exit + list = exit>.
That's why
sub listy {
is considered as always returning an unbounded list.
-Also, the convolution law does not behave the same when C<list> elements are involved : in the following example,
+Also, the convolution law does not behave the same when C<list> or C<exit> elements are involved : in the following example,
sub oneorlist {
if (rand < 0.1) {
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) = @_;
use strict;
use warnings;
-use Test::More tests => 32;
+use Test::More tests => 20;
use Sub::Nary;
'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');
-
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 ],
[ [ 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;
--- /dev/null
+#!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;
+}
projects / perl / modules / Sub-Nary.git / commitdiff