use strict;
use warnings;
use Math::MPFR qw(:mpfr);
use Config;
print "1..10\n";
print "# Using Math::MPFR version ", $Math::MPFR::VERSION, "\n";
print "# Using mpfr library version ", MPFR_VERSION_STRING, "\n";
print "# Using gmp library version ", Math::MPFR::gmp_v(), "\n";
if(Math::MPFR::_has_longdouble()) {print "Using long double\n"}
else {print "Not using long double\n"}
Rmpfr_set_default_prec(300);
if(Math::MPFR::_has_longdouble()) {
my $ok = '';
my $n = (2 ** 55) + 0.5;
my $ld1 = Math::MPFR->new($n);
my $ld2 = Math::MPFR::new($n);
my $ld3 = Math::MPFR->new();
Rmpfr_set_ld($ld3, $n, GMP_RNDN);
if(
$ld1 == $ld2 &&
$ld2 == $ld3 &&
$ld2 <= $n &&
$ld2 >= $n &&
$ld2 < $n + 1 &&
$ld2 > $n - 1 &&
($ld2 <=> $n) == 0 &&
($ld2 <=> $n - 1) > 0 &&
($ld2 <=> $n + 1) < 0 &&
$ld2 != $n - 1
) {$ok .= 'a'}
my $d2 = Rmpfr_get_ld($ld1, GMP_RNDN);
if($d2 == $n) {$ok .= 'b'}
if(!Rmpfr_cmp_ld($ld1, $n)) {$ok .= 'c'}
if($ok eq 'abc') {print "ok 1\n"}
else {print "not ok 1 $ok\n"}
$ok = '';
# Check the overloaded operators.
if($ld1 - 1 == $n - 1) {$ok .= 'a'}
$ld1 -= 1;
if($ld1 == $n - 1) {$ok .= 'b'}
$ld1 = $ld1 / 2;
if($ld1 == ($n - 1) / 2) {$ok .= 'c'}
$ld1 = $ld1 * 2;
if($ld1 == $n - 1) {$ok .= 'd'}
$ld1 /= 2;
if($ld1 == ($n - 1) / 2) {$ok .= 'e'}
$ld1 *= 2;
if($ld1 == $n - 1) {$ok .= 'f'}
if($ld1 + 1 == $n) {$ok .= 'g'}
$ld1 += 1;
if($ld1 == $n) {$ok .= 'h'}
if($ld1 ** 0.5 < 189812531.25 &&
$ld1 ** 0.5 > 189812531.24) {$ok .= 'i'}
$ld1 **= 0.5;
if($ld1 < 189812531.25 &&
$ld1 > 189812531.24) {$ok .= 'j'}
if($ok eq 'abcdefghij') {print "ok 2\n"}
else {print "not ok 2 $ok\n"}
my $bits = $Config::Config{longdblsize} > $Config::Config{doublesize} ? $Config::Config{doublesize} * 7 : 50;
$n = (2 ** $bits) + 0.5;
my $ld4 = Math::MPFR->new($n);
if($ld4 == int($ld4)) { print "not ok 3 precision has been lost: $ld4\n"}
else {print "ok 3\n"}
}
else {
my $ok = '';
my $int1 = Rmpfr_init();
eval{Rmpfr_set_ld($int1, 2 ** 23, GMP_RNDN);};
if($@ =~ /not implemented on this build of perl/i) {$ok = 'a'}
eval{Rmpfr_cmp_ld($int1, 2 ** 23);};
if($@ =~ /not implemented on this build of perl/i) {$ok .= 'b'}
eval{Rmpfr_get_ld($int1, GMP_RNDN);};
if($@ =~ /not implemented on this build of perl/i) {$ok .= 'c'}
eval{my($int2, $ret) = Rmpfr_init_set_ld(2 ** 23, GMP_RNDN);};
if($@ =~ /not implemented on this build of perl/i) {$ok .= 'd'}
if($ok eq 'abcd') {print "ok 1\n"}
else {print "not ok 1 $ok\n"}
warn "Skipping test 2 - nothing to test\n";
print "ok 2\n";
warn "Skipping test 3 - nothing to test\n";
print "ok 3\n";
}
if(Math::MPFR::_has_longdouble()) {
my $mpfr = Math::MPFR->new('1' x 62, 2);
my $mpfr2 = Rmpfr_init();
my $ok = '';
if ($mpfr < 4611686018427387904 && $mpfr > 4611686018427387902) {$ok .= 'a'}
if ($mpfr <= 4611686018427387904 && $mpfr >= 4611686018427387902) {$ok .= 'b'}
if ($mpfr == 4611686018427387903) {$ok .= 'c'}
if ($mpfr <= 4611686018427387903) {$ok .= 'd'}
if ($mpfr >= 4611686018427387903) {$ok .= 'e'}
my $ld = Rmpfr_get_ld($mpfr, GMP_RNDN);
if ($ld < 4611686018427387904 && $ld > 4611686018427387902) {$ok .= 'f'}
if ($ld == 4611686018427387903) {$ok .= 'g'}
my $cmp = $mpfr <=> 4611686018427387902;
if($cmp > 0) {$ok .= 'h'}
$cmp = $mpfr <=> 4611686018427387903;
if($cmp == 0) {$ok .= 'i'}
$cmp = $mpfr <=> 4611686018427387904;
if($cmp < 0) {$ok .= 'j'}
$cmp = 4611686018427387902 <=> $mpfr;
if($cmp < 0) {$ok .= 'k'}
$cmp = 4611686018427387903 <=> $mpfr;
if($cmp == 0) {$ok .= 'l'}
$cmp = 4611686018427387904 <=> $mpfr;
if($cmp > 0) {$ok .= 'm'}
Rmpfr_set_ld($mpfr2, 4611686018427387903, GMP_RNDN);
if($mpfr2 == $mpfr) {$ok .= 'n'}
if($ok eq 'abcdefghijklmn') {print "ok 4\n"}
else {print "not ok 4 $ok\n"}
}
else {
warn "Skipping test 4 - no long double support\n";
print "ok 4\n";
}
my $num1 = Math::MPFR->new(100);
my $exp = \$num1;
if(Math::MPFR::_has_longdouble()) {
my $double = Rmpfr_get_ld_2exp($exp, $num1, GMP_RNDN);
if($double > 0.781249 && $double < 0.781251 && $exp == 7) {print "ok 5\n"}
else {
warn "\n Got (double): $double\n Expected: 0.78125\n\n",
" Got (exp): $exp\n Expected: 7\n";
print "not ok 5\n";
}
}
else {
eval{my $double = Rmpfr_get_ld_2exp($exp, $num1, GMP_RNDN);};
if($@ =~ /Rmpfr_get_ld_2exp not implemented/) {print "ok 5\n"}
else {
warn "\n\$\@: $@\n";
print "not ok 5\n";
}
}
if(Math::MPFR::_has_longdouble()) {
my $double = (2 ** 55) + 0.5;
if($double == Rmpfr_get_NV(Math::MPFR->new($double), GMP_RNDN)) {print "ok 6\n"}
else {
warn "\nGot: ", Rmpfr_get_NV(Math::MPFR->new($double), GMP_RNDN) , "\nExpected: $double\n";
print "not ok 43\n";
}
}
else {
warn "Skipping test 6 - no long double support\n";
print "ok 6\n";
}
if(Math::MPFR::_has_longdouble()) {
my $nan = Math::MPFR->new();
my $posinf = Math::MPFR->new('inf');
my $neginf = Math::MPFR->new('-inf');
my $ok = '';
if($posinf == - $neginf) {$ok .= 'a'}
else {warn "a: $posinf ", $neginf * -1, "\n"}
my $double = Rmpfr_get_ld($nan, GMP_RNDN);
Rmpfr_set_ld($nan, $double, GMP_RNDN);
if(Rmpfr_nan_p($nan)) {$ok .= 'b'}
else {warn "b: $nan\n"}
$double = Rmpfr_get_ld($posinf, GMP_RNDN);
Rmpfr_set_ld($posinf, $double, GMP_RNDN);
if(Rmpfr_inf_p($posinf) && $posinf > 0) {$ok .= 'c'}
else {warn "c: $posinf\n"}
$double = Rmpfr_get_ld($neginf, GMP_RNDN);
Rmpfr_set_ld($neginf, $double, GMP_RNDN);
if(Rmpfr_inf_p($neginf) && $neginf < 0) {$ok .= 'd'}
else {warn "d: $neginf\n"}
$double = Rmpfr_get_NV($nan, GMP_RNDN);
Rmpfr_set_ld($nan, $double, GMP_RNDN);
if(Rmpfr_nan_p($nan)) {$ok .= 'e'}
else {warn "e: $nan\n"}
$double = Rmpfr_get_NV($posinf, GMP_RNDN);
Rmpfr_set_ld($posinf, $double, GMP_RNDN);
if(Rmpfr_inf_p($posinf) && $posinf > 0) {$ok .= 'f'}
else {warn "f: $posinf\n"}
$double = Rmpfr_get_NV($neginf, GMP_RNDN);
Rmpfr_set_ld($neginf, $double, GMP_RNDN);
if(Rmpfr_inf_p($neginf) && $neginf < 0) {$ok .= 'g'}
else {warn "g: $neginf\n"}
if($ok eq 'abcdefg') {print "ok 7\n"}
else {print "not ok 7 $ok\n"}
}
else {
warn "Skipping test 7 - no long double support\n";
print "ok 7\n";
}
if(Math::MPFR::_has_longdouble()) {
# Check that the mpfr_get_ld() bug has been fixed (mpfr-2.4.2 and later only)
if(MPFR_VERSION > 132097) {
my $prec = Rmpfr_get_default_prec();
Rmpfr_set_default_prec(64);
my $bugtest = Math::MPFR->new(-12345);
Rmpfr_exp($bugtest, $bugtest, GMP_RNDN);
my $ld = Rmpfr_get_ld($bugtest, GMP_RNDN);
Rmpfr_set_default_prec($prec);
if($ld < 0.000000001 && $ld >= 0){print "ok 8\n"}
else {
warn "Got: $ld\n";
print "not ok 8\n";
}
}
else {
warn "Skipping test 8 - mpfr_get_ld bug with mpfr-2.4.1 and earlier will cause the test to fail\n";
print "ok 8\n";
}
}
else {
warn "Skipping test 8 - no long double support\n";
print "ok 8\n";
}
# Test for a bug that affects Double-Double type only.
if(Math::MPFR::_has_longdouble()) {
my $prob1 = Rmpfr_init2(2097);
my $prob2 = Rmpfr_init2(2098);
my $p_val = (2 ** 1023) + (2 ** -1074);
my $res = $p_val > 2 ** 1023 ? 1 : 0;
my $res1 = Rmpfr_set_ld($prob1, $p_val, MPFR_RNDN);
my $res2 = Rmpfr_set_ld($prob2, $p_val, MPFR_RNDN);
if($res) { # double-double
if($res1 == -1 && $res2 == 0) {
print "ok 9\n";
}
else {
warn "\nDouble-Double type: \$res1: $res1 \$res2: $res2\n";
print "not ok 9\n";
}
}
else {
if(!$res1 && !$res2) {
print "ok 9\n";
}
else {
warn "\nNOT Double-Double type: \$res1: $res1 \$res2: $res2\n";
print "not ok 9\n";
}
}
}
else {
warn "Skipping test 9 - no long double support\n";
print "ok 9\n";
}
my $nv;
# mpfr_get_ld is buggy for 64-bit subnormals on mpfr 3.1.4 (19868) and earlier
# Since we don't have 64-bit floats on double-double architectures, we can skip
# this test if LDBL_DIG == 31.
if(Math::MPFR::_LDBL_DIG() == 31) {
warn "\n Skipping test 10 for double-double nvtype\n";
print "ok 10\n";
}
else {
eval{$nv = Rmpfr_get_ld(Math::MPFR->new("2e-4950"), MPFR_RNDN);};
if($@ =~ /^Rmpfr_get_ld not implemented/) {
warn "Skipping test 10 - no long double support\n";
print "ok 10\n";
}
else {
if(MPFR_VERSION() <= 196868) {
if(2e-4956 == 0) {
# bug exists for extended precision (64-bit) subnormal long double
if($@ =~ /^\sVersion 3\.1\.5/) {print "ok 10\n"}
else {
warn "\n\$\@: $@\n";
print "not ok 10\n";
}
}
else {
# no bug for quad (113-bit) subnormal long double
if(!$@ && $nv != 0) {print "ok 10\n"}
else {
warn "\n\$\@: $@\n\$nv: $nv\n";
print "not ok 10";
}
}
}
else {
if($nv > 0) {print "ok 10\n"}
else {
warn "$nv !> 0\n";
print "not ok 10\n";
}
}
}
}