diff --git a/Basic/Ops/ops.pd b/Basic/Ops/ops.pd index 42e32f4d7..61878f828 100644 --- a/Basic/Ops/ops.pd +++ b/Basic/Ops/ops.pd @@ -373,14 +373,26 @@ sub PDL::log10 { # pp_def( 'assgn', -# HandleBad => 1, + HandleBad => 1, Pars => 'a(); [o]b();', Code => '$b() = $a();', -# BadCode => -# 'if ( $ISBAD(a()) ) { $SETBAD(b()); } else { $b() = $a(); }', + BadCode => + 'if ( $ISBAD(a()) ) { $SETBAD(b()); } else { $b() = $a(); }', Doc => 'Plain numerical assignment. This is used to implement the ".=" operator', + BadDoc => +'If C is a child piddle (e.g., the result of a slice) and bad values are generated in C, +the bad value flag is set in C, but it is B automatically propagated back to the parent of C. +The following idiom ensures that the badflag is propagated back to the parent of C: + + $pdl->slice(":,(1)") .= PDL::Bad_aware_func(); + $pdl->badflag(1); + $pdl->check_badflag(); + +This is unnecessary if $pdl->badflag is known to be 1 before the slice is performed. + +See http://pdl.perl.org/PDLdocs/BadValues.html#dataflow_of_the_badflag for details.' ); # pp_def assgn #pp_export_nothing(); diff --git a/t/ops.t b/t/ops.t index b8da4f4b7..a0194366d 100644 --- a/t/ops.t +++ b/t/ops.t @@ -1,13 +1,8 @@ +use Test::More tests => 45; use PDL::LiteF; +use PDL::Config; kill INT,$$ if $ENV{UNDER_DEBUGGER}; # Useful for debugging. -sub ok { - my $no = shift ; - my $result = shift ; - print "not " unless $result ; - print "ok $no\n" ; -} - sub tapprox { my($a,$b,$c,$d) = @_; $c = abs($a-$b); @@ -15,8 +10,6 @@ sub tapprox { return $d < 0.01; } -print "1..44\n"; - # $a0 = zeroes 3,5; # $b0 = xvals $a0; @@ -26,19 +19,19 @@ $b = yvals zeroes 3,5; $c = $a + $b; -ok(1,$c->at(2,2) == 4); -ok(2,$c->at(2,3) == 5); +ok($c->at(2,2) == 4); +ok($c->at(2,3) == 5); eval '$c->at(3,3)'; -ok(3,$@ =~ /Position out of range/); +ok($@ =~ /Position out of range/); $d = pdl 5,6; $e = $d - 1; -ok(4,$e->at(0) == 4); -ok(5,$e->at(1) == 5); +ok($e->at(0) == 4); +ok($e->at(1) == 5); $f = 1 - $d; -ok(6,$f->at(0) == -4); -ok(7,$f->at(1) == -5); +ok($f->at(0) == -4); +ok($f->at(1) == -5); # Now, test one operator from each group # biop1 tested already @@ -48,111 +41,128 @@ $b = pdl 1.5; $c = $a > $b; -ok(8,$c->at(1) == 0); -ok(9,$c->at(2) == 1); +ok($c->at(1) == 0); +ok($c->at(2) == 1); $a = byte pdl 0,1,3; $c = $a << 2; -ok(10,$c->at(0) == 0); -ok(11,$c->at(1) == 4); -ok(12,$c->at(2) == 12); +ok($c->at(0) == 0); +ok($c->at(1) == 4); +ok($c->at(2) == 12); $a = pdl 16,64,9; $b = sqrt($a); -ok(13,tapprox($b,(pdl 4,8,3))); +ok(tapprox($b,(pdl 4,8,3))); # See that a is unchanged. -ok(14,$a->at(0) == 16); +ok($a->at(0) == 16); $a = pdl 1,0; $b = ! $a; -ok(15,$b->at(0) == 0); -ok(16,$b->at(1) == 1); +ok($b->at(0) == 0); +ok($b->at(1) == 1); $a = pdl 12,13,14,15,16,17; $b = $a % 3; -ok(17,$b->at(0) == 0); -ok(18,$b->at(1) == 1); -ok(19,$b->at(3) == 0); +ok($b->at(0) == 0); +ok($b->at(1) == 1); +ok($b->at(3) == 0); # [ More modulus testing farther down! ] # Might as well test this also -ok(20,tapprox((pdl 2,3),(pdl 2,3))); -ok(21,!tapprox((pdl 2,3),(pdl 2,4))); +ok(tapprox((pdl 2,3),(pdl 2,3))); +ok(!tapprox((pdl 2,3),(pdl 2,4))); # Simple function tests $a = pdl(2,3); -ok(22, tapprox(exp($a), pdl(7.3891,20.0855))); -ok(23, tapprox(sqrt($a), pdl(1.4142, 1.7321))); +ok(tapprox(exp($a), pdl(7.3891,20.0855))); +ok(tapprox(sqrt($a), pdl(1.4142, 1.7321))); # And and Or -ok(24, tapprox(pdl(1,0,1) & pdl(1,1,0), pdl(1,0,0))); -ok(25, tapprox(pdl(1,0,1) | pdl(1,1,0), pdl(1,1,1))); +ok(tapprox(pdl(1,0,1) & pdl(1,1,0), pdl(1,0,0))); +ok(tapprox(pdl(1,0,1) | pdl(1,1,0), pdl(1,1,1))); # atan2 -ok (26, tapprox(atan2(pdl(1,1), pdl(1,1)), ones(2) * atan2(1,1))); +ok (tapprox(atan2(pdl(1,1), pdl(1,1)), ones(2) * atan2(1,1))); $a = sequence (3,4); $b = sequence (3,4) + 1; -ok (27, tapprox($a->or2($b,0), $a | $b)); -ok (28, tapprox($a->and2($b,0), $a & $b)); -ok (29, tapprox($b->minus($a,0), $b - $a)); -ok (30, tapprox($b - $a, ones(3,4))); +ok (tapprox($a->or2($b,0), $a | $b)); +ok (tapprox($a->and2($b,0), $a & $b)); +ok (tapprox($b->minus($a,0), $b - $a)); +ok (tapprox($b - $a, ones(3,4))); # inplace tests $a = pdl 1; $sq2 = sqrt 2; # perl sqrt $a->inplace->plus(1,0); # trailing 0 is ugly swap-flag -ok(31, tapprox $a, pdl 2); +ok(tapprox $a, pdl 2); $warning_shutup = $warning_shutup = sqrt $a->inplace; -ok(32, tapprox $a, pdl($sq2)); +ok(tapprox $a, pdl($sq2)); $a = pdl 4; -ok(33, tapprox 2, sqrt($a->inplace)); +ok(tapprox 2, sqrt($a->inplace)); # log10 now uses C library # check using scalars and piddles $a = log10(110); $b = log(110) / log(10); -print "a: $a [ref(\$a)='", ref($a),"']\n"; -print "b: $b\n"; -ok(34, abs($a-$b) < 1.0e-5 ); +note "a: $a [ref(\$a)='", ref($a),"']\n"; +note "b: $b\n"; +ok(abs($a-$b) < 1.0e-5 ); $a = log10(pdl(110,23)); $b = log(pdl(110,23)) / log(10); -print "a: $a\n"; -print "b: $b\n"; -ok(35, tapprox $a, $b ); +note "a: $a\n"; +note "b: $b\n"; +ok(tapprox $a, $b ); # check inplace -ok(36, tapprox pdl(110,23)->inplace->log10(), $b ); +ok(tapprox pdl(110,23)->inplace->log10(), $b ); $data = ones 5; $data &= 0; -ok(37, all $data == 0); +ok(all $data == 0); $data |= 1; -ok(38, all $data == 1); +ok(all $data == 1); -ok(39, all $data eq $data); # check eq operator +ok(all $data eq $data); # check eq operator # check proper modulus... really we should do this for each datatype $a = xvals(15)-7; $b = $a % 3; -ok(40,sum($b != pdl(2,0,1,2,0,1,2,0,1,2,0,1,2,0,1)) == 0); +ok(sum($b != pdl(2,0,1,2,0,1,2,0,1,2,0,1,2,0,1)) == 0); $b = $a % -3; -ok(41,sum($b != pdl(-1,0,-2,-1,0,-2,-1,0,-2,-1,0,-2,-1,0,-2))==0); +ok(sum($b != pdl(-1,0,-2,-1,0,-2,-1,0,-2,-1,0,-2,-1,0,-2))==0); $b = $a % 0; -ok(42,sum($b != 0) == 0); +ok(sum($b != 0) == 0); #check that modulus works on PDL_Index types correctly $b = $a->qsorti; $c = $b % 3; -ok(43,all($c->double==pdl("0 1 2 " x 5))); -ok(44,longlong(10)%longlong(5)==0); +ok(all($c->double==pdl("0 1 2 " x 5))); +ok(longlong(10)%longlong(5)==0); + +TODO: { + # Check badflag propagation with .= (Ops::assgn) sf.net bug 3543056 + local $TODO = "Badflag needs to propagate via assignment"; + todo_skip 'No BADVAL', 1 if !$PDL::Config{WITH_BADVAL}; + + $a = sequence(10); + $b = sequence(5); + $b->inplace->setvaltobad(3); + $a->slice('0:4') .= $b; + # NOTE TODO + # if you set the badflag manually, this will work, but to Do The Right + # Thing, this should be automatic: + # $a->badflag(1); + # $a->check_badflag(); + ok($a->badflag == 1 && $a->nbad == 1); +}