diff options
| -rw-r--r-- | ext/B/t/deparse.t | 28 | ||||
| -rw-r--r-- | lib/overload.t | 42 | ||||
| -rw-r--r-- | op.c | 33 | ||||
| -rwxr-xr-x | t/op/do.t | 14 | ||||
| -rwxr-xr-x | t/op/lop.t | 12 |
5 files changed, 121 insertions, 8 deletions
diff --git a/ext/B/t/deparse.t b/ext/B/t/deparse.t index a8cb3560d0..f28c68821a 100644 --- a/ext/B/t/deparse.t +++ b/ext/B/t/deparse.t @@ -27,7 +27,7 @@ BEGIN { require feature; feature->import(':5.10'); } -use Test::More tests => 64; +use Test::More tests => 66; use B::Deparse; my $deparse = B::Deparse->new(); @@ -432,3 +432,29 @@ use constant H => { "#" => 1 }; H->{"#"} # SKIP ?$B::Deparse::VERSION <= 0.87 && "TODO optimized away 0 not yet fixed" # 57 (cpan-bug #33708) foreach my $i (@_) { 0 } +#### +# 58 tests with not, not optimized +x() unless $a; +x() if not $a and $b; +x() if $a and not $b; +x() unless not $a and $b; +x() unless $a and not $b; +x() if not $a or $b; +x() if $a or not $b; +x() unless not $a or $b; +x() unless $a or not $b; +#### +# 59 tests with not, optimized +x() if not $a; +x() unless not $a; +x() if not $a and not $b; +x() unless not $a and not $b; +x() if not $a or not $b; +x() unless not $a or not $b; +>>>> +x() unless $a; +x() if $a; +x() unless $a or $b; +x() if $a or $b; +x() unless $a and $b; +x() unless not $a && $b; diff --git a/lib/overload.t b/lib/overload.t index 7c2476cc8c..f10e09255c 100644 --- a/lib/overload.t +++ b/lib/overload.t @@ -47,7 +47,7 @@ sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead package main; $| = 1; -use Test::More tests => 558; +use Test::More tests => 574; $a = new Oscalar "087"; @@ -1225,6 +1225,46 @@ foreach my $op (qw(<=> == != < <= > >=)) { ok(!$b, "Expect overloaded boolean"); ok(!$a, "Expect overloaded boolean"); } + +{ + package Flrbbbbb; + use overload + bool => sub { shift->{truth} eq 'yes' }, + '0+' => sub { shift->{truth} eq 'yes' ? '1' : '0' }, + '!' => sub { shift->{truth} eq 'no' }, + fallback => 1; + + sub new { my $class = shift; bless { truth => shift }, $class } + + package main; + + my $yes = Flrbbbbb->new('yes'); + my $x; + $x = 1 if $yes; is($x, 1); + $x = 2 unless $yes; is($x, 1); + $x = 3 if !$yes; is($x, 1); + $x = 4 unless !$yes; is($x, 4); + + my $no = Flrbbbbb->new('no'); + $x = 0; + $x = 1 if $no; is($x, 0); + $x = 2 unless $no; is($x, 2); + $x = 3 if !$no; is($x, 3); + $x = 4 unless !$no; is($x, 3); + + $x = 0; + $x = 1 if !$no && $yes; is($x, 1); + $x = 2 unless !$no && $yes; is($x, 1); + $x = 3 if $no || !$yes; is($x, 1); + $x = 4 unless $no || !$yes; is($x, 4); + + $x = 0; + $x = 1 if !$no || !$yes; is($x, 1); + $x = 2 unless !$no || !$yes; is($x, 1); + $x = 3 if !$no && !$yes; is($x, 1); + $x = 4 unless !$no && !$yes; is($x, 4); +} + { use Scalar::Util 'weaken'; @@ -1138,6 +1138,20 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_OR: case OP_AND: + kid = cLOGOPo->op_first; + if (kid->op_type == OP_NOT + && (kid->op_flags & OPf_KIDS) + && !PL_madskills) { + if (o->op_type == OP_AND) { + o->op_type = OP_OR; + o->op_ppaddr = PL_ppaddr[OP_OR]; + } else { + o->op_type = OP_AND; + o->op_ppaddr = PL_ppaddr[OP_AND]; + } + op_null(kid); + } + case OP_DOR: case OP_COND_EXPR: case OP_ENTERGIVEN: @@ -4442,7 +4456,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) LOGOP *logop; OP *o; OP *first = *firstp; - OP * const other = *otherp; + OP *other = *otherp; + int prepend_not = 0; PERL_ARGS_ASSERT_NEW_LOGOP; @@ -4450,10 +4465,11 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) return newBINOP(type, flags, scalar(first), scalar(other)); scalarboolean(first); - /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */ + /* optimize AND and OR ops that have NOTs as children */ if (first->op_type == OP_NOT - && (first->op_flags & OPf_SPECIAL) && (first->op_flags & OPf_KIDS) + && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */ + || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */ && !PL_madskills) { if (type == OP_AND || type == OP_OR) { if (type == OP_AND) @@ -4466,6 +4482,15 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) first->op_next = o->op_next; cUNOPo->op_first = NULL; op_free(o); + if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */ + o = other; + other = *otherp = cUNOPo->op_first; + if (o->op_next) + other->op_next = o->op_next; + cUNOPo->op_first = NULL; + op_free(o); + prepend_not = 1; /* prepend a NOT op later */ + } } } if (first->op_type == OP_CONST) { @@ -4582,7 +4607,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) CHECKOP(type,logop); - o = newUNOP(OP_NULL, 0, (OP*)logop); + o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop); other->op_next = o; return o; @@ -29,7 +29,7 @@ sub ok { return $ok; } -print "1..22\n"; +print "1..26\n"; # Test do &sub and proper @_ handling. $_[0] = 0; @@ -92,6 +92,18 @@ ok( (!defined do 6) && $!, "'do 6' : $!" ); push @t, ($u = (do {} . "This should be pushed.")); ok( $#t == 0, "empty do result value" ); +$zok = ''; +$owww = do { 1 if $zok }; +ok( $owww eq '', 'last is unless' ); +$owww = do { 2 unless not $zok }; +ok( $owww == 1, 'last is if not' ); + +$zok = 'swish'; +$owww = do { 3 unless $zok }; +ok( $owww eq 'swish', 'last is unless' ); +$owww = do { 4 if not $zok }; +ok( $owww eq '', 'last is if not' ); + END { 1 while unlink("$$.16", "$$.17", "$$.18"); } diff --git a/t/op/lop.t b/t/op/lop.t index d57271abd6..a78ac728ae 100755 --- a/t/op/lop.t +++ b/t/op/lop.t @@ -9,7 +9,7 @@ BEGIN { @INC = '../lib'; } -print "1..7\n"; +print "1..9\n"; my $test = 0; for my $i (undef, 0 .. 2, "", "0 but true") { @@ -42,3 +42,13 @@ my $i = 0; (($i ||= 1) &&= 3) += 4; print "not " unless $i == 7; print "ok ", ++$test, "\n"; + +my ($x, $y) = (1, 8); +$i = !$x || $y; +print "not " unless $i == 8; +print "ok ", ++$test, "\n"; + +($x, $y) = (0, 9); +$i = !$x && $y; +print "not " unless $i == 9; +print "ok ", ++$test, "\n"; |