From: Vincent Pit Date: Thu, 21 Aug 2008 10:16:11 +0000 (+0200) Subject: Add support for die() X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=3a7f23b3ef06db23f3bd2f2707e70b61c6a15b4f;p=perl%2Fmodules%2FSub-Nary.git Add support for die() --- diff --git a/MANIFEST b/MANIFEST index cb97b5c..e818157 100644 --- a/MANIFEST +++ b/MANIFEST @@ -18,6 +18,7 @@ t/23-branch.t t/24-ops.t t/25-grepmap.t t/26-exit.t +t/27-die.t t/90-boilerplate.t t/91-pod.t t/92-pod-coverage.t diff --git a/Nary.xs b/Nary.xs index 0329eea..66eced6 100644 --- a/Nary.xs +++ b/Nary.xs @@ -31,6 +31,7 @@ STATIC void sn_store_ent(pTHX_ HV *tb, SV *key, SV *val, U32 hash) { STATIC U32 sn_hash_list = 0; STATIC U32 sn_hash_exit = 0; +STATIC U32 sn_hash_die = 0; /* --- XS ------------------------------------------------------------------ */ @@ -42,6 +43,7 @@ BOOT: { PERL_HASH(sn_hash_list, "list", 4); PERL_HASH(sn_hash_exit, "exit", 4); + PERL_HASH(sn_hash_die, "die", 3); } void @@ -248,13 +250,13 @@ PROTOTYPE: @ PREINIT: HV *res[3]; SV *val; - SV *exit1, *list1; + SV *kexit, *klist, *kdie; SV *temp; HE *key, *old; I32 i; I32 n = 0, o; I32 j, n1, n2; - NV pl = 0, pe = 0; + NV pe = 0, pd = 0, pl = 0; sn_combcache *cache = NULL; I32 cachelen = 1; CODE: @@ -268,7 +270,7 @@ CODE: temp = sv_2mortal(newSViv(0)); for (i = 0; i < items; ++i) { SV *cur = ST(i); - NV pe1 = 0, pl1 = 0; + NV pe1 = 0, pd1 = 0, pd2, pl1 = 0; if (!SvOK(cur)) continue; if (!SvROK(cur)) { @@ -285,29 +287,42 @@ CODE: res[o] = newHV(); else hv_clear(res[o]); - exit1 = hv_delete((HV *) cur, "exit", 4, 0); + kexit = hv_delete((HV *) cur, "exit", 4, 0); n1 = hv_iterinit((HV *) cur); - if (exit1) { + if (kexit) { if (!n1) { - pe = 1; + pe = 1 - pd; pl = 0; n = o; break; } - pe1 = SvNV(exit1); + pe1 = SvNV(kexit); } - list1 = hv_delete((HV *) cur, "list", 4, 0); - if (list1) { + kdie = hv_delete((HV *) cur, "die", 3, 0); + if (kdie) { if (n1 == 1) { - pl = 1 - pe; + pd = 1 - pe; + pl = 0; + n = o; + break; + } + --n1; + pd1 = SvNV(kdie); + } + klist = hv_delete((HV *) cur, "list", 4, 0); + if (klist) { + if (n1 == 1) { + pl = 1 - (pe + pd); n = o; break; } - pl1 = SvNV(list1); + pl1 = SvNV(klist); } - pl = pl1 * (1 - pe) + pl * (1 - pe1) - pl * pl1; - pe = pe + (1 - pe) * pe1; - n2 = hv_iterinit(res[n]); + pl = pl1 * (1 - (pd + pe)) + pl * (1 - (pd1 + pe1)) - pl * pl1; + pd2 = pd1 * (1 - pe) + pd - pd * pd1; + pe = pe1 * (1 - pd) + pe - pe * pe1; + pd = pd2; + n2 = hv_iterinit(res[n]); if (!n2) { cache[0].k = 0; cache[0].v = 1; @@ -343,6 +358,8 @@ CODE: SvREFCNT_dec(res[2]); if (pe) sn_store(res[n], "exit", 4, newSVnv(pe), sn_hash_exit); + if (pd) + sn_store(res[n], "die", 3, newSVnv(pd), sn_hash_die); if (pl) sn_store(res[n], "list", 4, newSVnv(pl), sn_hash_list); if (n == 1) diff --git a/lib/Sub/Nary.pm b/lib/Sub/Nary.pm index f789e69..159dd8e 100644 --- a/lib/Sub/Nary.pm +++ b/lib/Sub/Nary.pm @@ -426,6 +426,20 @@ sub pp_exit { return $r, undef; } +sub pp_die { + my ($self, $op) = @_; + + my ($r, undef) = $self->inspect_kids($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) = @_; @@ -503,6 +517,18 @@ sub pp_aassign { $self->inspect($op); } +sub pp_leavetry { + my ($self, $op) = @_; + + my ($r, $l) = $self->inspect_kids($op); + if (defined $r) { + my $d = delete $r->{die}; + $r->{0} += $d if defined $d; + } + + return $r, $l; +} + sub pp_leaveloop { my ($self, $op) = @_; diff --git a/t/16-combine.t b/t/16-combine.t index 7f0b459..bfd9d4e 100644 --- a/t/16-combine.t +++ b/t/16-combine.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 41; +use Test::More tests => 60; use Sub::Nary; @@ -12,7 +12,11 @@ use Sub::Nary; 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 $h1d = { 1 => 0.5, die => 0.5 }; my $h1le = { 1 => 0.25, list => 0.25, exit => 0.5 }; +my $h12e = { 1 => 0.25, 2 => 0.25, exit => 0.5 }; +my $h1ld = { 1 => 0.25, list => 0.25, die => 0.5 }; +my $h12d = { 1 => 0.25, 2 => 0.25, die => 0.5 }; my @tests = ( [ [ ], undef ], @@ -57,11 +61,44 @@ my @tests = ( [ [ '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 } ], + [ [ 'die' ], 'die' ], + [ [ 'die', 2 ], 'die' ], + [ [ { %$h1d }, 2 ], { die => 0.5, 3 => 0.5 } ], + [ [ { %$h1d }, 1 ], { die => 0.5, 2 => 0.5 } ], + [ [ { %$h1d }, { %$h1d } ], { die => 0.75, 2 => 0.25 } ], + + [ [ { %$h1d }, { %$h1l } ], { die => 0.5, list => 0.25, 2 => 0.25 } ], + [ [ { %$h1l }, { %$h1d } ], { die => 0.5, list => 0.25, 2 => 0.25 } ], + [ [ { %$h1l }, { %$h1ld } ], { die => 0.5, list => 0.375, 2 => 0.125 } ], + [ [ { %$h1d }, { %$h1ld } ], { die => 0.75, list => 0.125, 2 => 0.125 } ], + + [ [ { %$h1e }, { %$h1d } ], { exit => 0.5, die => 0.25, 2 => 0.25 } ], + [ [ { %$h1d }, { %$h1e } ], { exit => 0.25, die => 0.5, 2 => 0.25 } ], + [ [ { %$h1e }, { %$h1ld } ], { exit => 0.5, die => 0.25, + list => 0.125, 2 => 0.125 } ], + [ [ { %$h1d }, { %$h1le } ], { exit => 0.25, die => 0.5, + list => 0.125, 2 => 0.125 } ], + + [ [ { %$h12d }, { %$h1le } ], { exit => 0.25, die => 0.5, + list => 0.125, 2 => 0.0625, 3 => 0.0625 } ], + [ [ { %$h12e }, { %$h1ld } ], { exit => 0.5, die => 0.25, + list => 0.125, 2 => 0.0625, 3 => 0.0625 } ], + [ [ { %$h1ld }, { %$h12e } ], { exit => 0.25, die => 0.5, + list => 0.125, 2 => 0.0625, 3 => 0.0625 } ], + [ [ { %$h1le }, { %$h12d } ], { exit => 0.5, die => 0.25, + list => 0.125, 2 => 0.0625, 3 => 0.0625 } ], + + [ [ { %$h1ld }, { %$h1le } ], { exit => 0.25, die => 0.5, + list => 0.1875, 2 => 0.0625 } ], + [ [ { %$h1le }, { %$h1ld } ], { exit => 0.5, die => 0.25, + list => 0.1875, 2 => 0.0625 } ], + [ [ $h1l, $h1l ], { 2 => 0.25, list => 0.5 } ], # Side effects ); diff --git a/t/27-die.t b/t/27-die.t new file mode 100644 index 0000000..3880282 --- /dev/null +++ b/t/27-die.t @@ -0,0 +1,47 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 12; + +use Sub::Nary; + +my $sn = Sub::Nary->new(); + +my ($x, $y); + +sub dies { + if ($x) { + die do { return 3, 4 if $y } + } + @_[0 .. 2]; +} + +my @tests = ( + [ sub { die }, { die => 1 } ], + [ sub { die 1 }, { die => 1 } ], + [ sub { if ($x) { die } }, { die => 0.5, 1 => 0.5 } ], + [ sub { if (die) { return 1, 2 } }, { die => 1 } ], + [ sub { die do { return 3, 4 } }, { 2 => 1 } ], + [ sub { $x ? die($y ? die : return(2, 3)) : 4 }, + { die => 0.25, 2 => 0.25, 1 => 0.5 } ], + + [ \&dies, { die => 0.25, 2 => 0.25, 3 => 0.5 } ], + [ sub { dies(), do { $x ? @_ : 1 } }, { die => 0.25, 3 => 0.125, 4 => 0.25, + list => (0.25 + 0.5) * 0.5 } ], + [ sub { dies(), 1, do { $x ? @_ : 1 } }, + { die => 0.25, 4 => 0.125, 5 => 0.25, list => (0.25 + 0.5) * 0.5 } ], + + [ sub { eval "1, do { die }, 3" }, 'list' ], + [ sub { eval { die } }, { 0 => 1 } ], + [ sub { eval { $x ? die : (4, 5) } }, { 0 => 0.5, 2 => 0.5 } ], +); + +my $i = 1; +for (@tests) { + my $r = $sn->nary($_->[0]); + my $exp = ref $_->[1] ? $_->[1] : { $_->[1] => 1 }; + is_deeply($r, $exp, 'die test ' . $i); + ++$i; +}