## This file generated by InlineX::C2XS (version 0.22) using Inline::C (version 0.53)
package Math::NV;
use warnings;
use strict;
use 5.010;
require Exporter;
*import = \&Exporter::import;
require DynaLoader;
$Math::NV::VERSION = '1.02';
DynaLoader::bootstrap Math::NV $Math::NV::VERSION;
@Math::NV::EXPORT = ();
@Math::NV::EXPORT_OK = qw(
nv nv_type mant_dig ld2binary ld_str2binary is_eq
bin2val Cprintf Csprintf nv_mpfr is_eq_mpfr
);
%Math::NV::EXPORT_TAGS = (all => [qw(
nv nv_type mant_dig ld2binary ld_str2binary is_eq
bin2val Cprintf Csprintf nv_mpfr is_eq_mpfr
)]);
eval {require Math::MPFR;};
if($@) {$Math::NV::no_mpfr = $@}
else {$Math::NV_no_mpfr = 0 }
$Math::NV::no_warn = 0; # set to true to disable warning about non-string argument
# %_itsa is utilised in the formulation of the diagnostic message
# when it's detected that the provided arg is not a string.
my %_itsa = (
1 => 'UV',
2 => 'IV',
3 => 'NV',
4 => 'string',
0 => 'unknown',
);
sub dl_load_flags {0} # Prevent DynaLoader from complaining and croaking
sub ld2binary {
my @ret = _ld2binary($_[0]);
my $prec = pop(@ret);
my $exp = pop(@ret);
my $mantissa = join '', @ret;
return ($mantissa, $exp, $prec);
}
sub ld_str2binary {
my @ret = _ld_str2binary($_[0]);
my $prec = pop(@ret);
my $exp = pop(@ret);
my $mantissa = join '', @ret;
return ($mantissa, $exp, $prec);
}
sub bin2val {
my($mantissa, $exp, $prec) = (shift, shift, shift);
my $sign = $mantissa =~ /^\-/ ? '-' : '';
# Remove everything upto and including the radix point
# as it now contains no useful information.
$mantissa =~ s/.+\.//;
# For our purposes the values $prec and $exp need
# to be reduced by 1.
$exp--;
# Perl bugs make the following (commented out) code unreliable,
# so we now hand the calculations over to C.
# (And there's no need to decrement $prec.)
#$prec--;
#for(0..$prec) {
# if(substr($mantissa, $_, 1)) {$val += 2**$exp}
# $exp--;
#}
my @mantissa = split //, $mantissa;
my $val = _bin2val($prec, $exp, \@mantissa);
$sign eq '-' ? return -$val : return $val;
}
sub is_eq {
unless($Math::NV::no_warn) {
my $itsa = $_[0];
$itsa = _itsa($itsa); # make sure that $_[0] IOK flag is not set
warn "Argument given to is_eq() is $_itsa{$itsa}, not a string - probably not what you want"
if $itsa != 4;
}
my $nv = $_[0];
my $check = nv($_[0]);
return 1 if $nv == $check;
if(mant_dig() == 64) {
# pack/unpack like to deliver irrelevant (ie ignored) leading bytes
# if NV is 80-bit long double
my $first = scalar(reverse(unpack("h*", pack("F<", $nv))));
$first = substr($first, length($first) - 20, 20);
my $second = scalar(reverse(unpack("h*", pack("F<", $check))));
$second = substr($second, length($second) - 20, 20);
warn "In is_eq:\nperl: $first vs C: $second\n\n";
}
else {
warn "In is_eq:\nperl: ",
scalar(reverse(unpack("h*", pack("F<", $nv)))), " vs C: ",
scalar(reverse(unpack("h*", pack("F<", $check)))), "\n\n";
}
return 0;
}
sub is_eq_mpfr {
if($Math::NV::no_mpfr) {die "In is_eq_mpfr(): $Math::NV::no_mpfr"}
unless($Math::NV::no_warn) {
my $itsa = $_[0];
$itsa = _itsa($itsa); # make sure that $_[0] IOK flag is not set
warn "Argument given to is_eq() is $_itsa{$itsa}, not a string - probably not what you want"
if $itsa != 4;
}
my $ret = 0;
my $nv = $_[0];
my $bits = mant_dig();
$bits = 2098 if $bits == 106; # double double
my $fr = Math::MPFR::Rmpfr_init2($bits);
Math::MPFR::Rmpfr_set_str($fr, $nv, 10, 0);
if($nv == Math::MPFR::Rmpfr_get_NV($fr, 0)) {$ret = 1}
else {
if($bits == 64) {
# pack/unpack like to deliver irrelevant (ie ignored) leading bytes
# if NV is 80-bit long double
my $first = scalar(reverse(unpack("h*", pack("F<", $nv))));
$first = substr($first, length($first) - 20, 20);
my $second = scalar(reverse(unpack("h*", pack("F<", Math::MPFR::Rmpfr_get_NV($fr, 0)))));
$second = substr($second, length($second) - 20, 20);
warn "In is_eq_mpfr:\nperl: $first vs mpfr: $second\n\n";
}
else {
warn "In is_eq_mpfr:\nperl: ",
scalar(reverse(unpack("h*", pack("F<", $nv)))), " vs mpfr: ",
scalar(reverse(unpack("h*", pack("F<", Math::MPFR::Rmpfr_get_NV($fr, 0))))), "\n\n";
}
}
return $ret;
}
sub nv_mpfr {
if($Math::NV::no_mpfr) {die "In nv_mpfr(): $Math::NV::no_mpfr"}
unless($Math::NV::no_warn) {
my $itsa = $_[0];
$itsa = _itsa($itsa); # make sure that $_[0] IOK flag is not set
warn "Argument given to is_eq() is $_itsa{$itsa}, not a string - probably not what you want"
if $itsa != 4;
}
my $bits;
if(!defined($_[1])) {$bits = mant_dig()}
else {$bits = $_[1]}
return _double_double($_[0]) if $bits == 106; # doubledouble
my $val = Math::MPFR::Rmpfr_init2($bits);
Math::MPFR::Rmpfr_set_str($val, $_[0], 10, 0);
if($bits == mant_dig() ) { # 53, 64, 106 or 113 bits
my $nv = Math::MPFR::Rmpfr_get_NV($val, 0);
my $ret = scalar(reverse(unpack("h*", pack("F<", $nv))));
# pack/unpack like to deliver irrelevant (ie ignored) leading bytes
# if NV is 80-bit long double
if($bits == 64) {
return substr($ret, length($ret) - 20, 20);
}
return $ret;
}
if($bits == 53) {
my $nv = Math::MPFR::Rmpfr_get_d($val, 0);
return scalar(reverse(unpack("h*", pack("d<", $nv))));
}
if($bits == 64) {
die "No _ld_bytes with this version ($Math::MPFR::VERSION) - need at least 3.27"
unless $Math::MPFR::VERSION > '3.26';
my @bytes = Math::MPFR::_ld_bytes($_[0], 64);
return join('', @bytes);
}
if($bits == 113) {
my $t;
eval{$t = Math::MPFR::_have_IEEE_754_long_double();}; # needs Math-MPFR-3.33, perl-5.22.
if(!$@ && $t) {
my @bytes = Math::MPFR::_ld_bytes($_[0], 113);
return join('', @bytes);
}
else { # assume __float128 (though that might not be the case)
die "No _f128_bytes with this version ($Math::MPFR::VERSION) - need at least 3.26"
unless $Math::MPFR::VERSION > 3.25;
my @bytes = Math::MPFR::_f128_bytes($_[0], 113);
return join('', @bytes);
}
}
die "Unrecognized value for bits ($bits)";
}
sub _double_double {
my $val = Math::MPFR::Rmpfr_init2(2098);
Math::MPFR::Rmpfr_set_str($val, shift, 10, 0);
my @val = _dd_obj($val);
return [scalar(reverse(unpack("h*", pack("d<", $val[0])))),
scalar(reverse(unpack("h*", pack("d<", $val[1]))))];
}
sub _dd_obj {
my $obj = shift;
my $msd = Math::MPFR::Rmpfr_get_d($obj, 0);
$obj -= $msd;
return ($msd, Math::MPFR::Rmpfr_get_d($obj, 0));
}
1;
__END__
=head1 NAME
Math::NV - compare the NV values that perl assigns with C and MPFR
=head1 DESCRIPTION
use Math::NV qw(:all);
$bool = is_eq('1e-298');
$bool = is_eq_mpfr('1e-298'); # iff Math::MPFR is available
If $bool is true, this suggests there is quite possibly no bug
in the assignment of the specified value.
If $bool is false, this implies that at least one of perl && C
(wrt is_eq) or mpfr (wrt is_eq_mpfr) suffer a bug in assigning
the specified value.
IME, it's perl that's usually wrong - though I've struck buggy
assignments with C.
I've not yet found a case where mpfr assigns incorrectly - and
I firmly expect that I won't ever find such a bug with that
library.
All mpfr values are assigned with a rounding mode of "to nearest,
ties to even". (This could be made configurable if requested.)
=head1 FUNCTIONS
$bool = is_eq($str);
Returns true if the value perl assigns to an NV from the string
$str is equal to the value C assigns to the C type specified by
$Config{nvtype} from the same string.
Else returns false - which implies that either perl or C is buggy
in its assignment of that value. (Or they could both be buggy.)
$bool = is_eq_mpfr($str);
Returns true if the value perl assigns from the string $str is
equal to the value mpfr assigns from the same string.
Else returns false - which implies that either perl or mpfr is
buggy in its assignment of that value. (Or they could both be
buggy - though it's very unlikely that mpfr suffers such a bug.)
$nv = nv($str); # scalar context
($nv, $iv) = nv($str); # list context
On perls whose NV is a C "double", assigns to $nv the value that
the C standard library function strtod($str) assigns.
On perls whose NV is a C "long double", assigns to $nv the value
that the C standard library function strtold($str) assigns.
On perls whose NV is a C "__float128", assigns to $nv the value
that the C standard library function strtofloat128($str) assigns.
In list context, also returns the number of characters that were
unparsed (ignored).
Generally you'll want $str to be a string - eg the string "2.3",
rather than the NV 2.3. Failure to adhere to this will result in
a warning - though you can disable this warning by setting
$Math::NV::no_warn to 1.
$hex = nv_mpfr($str, [$bits]);
If $bits is not specified, it will be set to the value returned by
mant_dig() - which is the appropriate value for the current perl
that is being run.
Valid values for $bits are 53 (double), 64 (80-bit extended
precision long double), 106 (double-double) and 113 (128-bit quad
long double or __float128). Other values will cause an error.
If $bits is set to 113, the string will be treated as a 128-bit
IEEE 754 long double iff $Math::MPFR::VERSION >= 3.33 &&
$Config{longdblkind} is either 1 or 2. Otherwise the value of 113
will be taken to indicate __float128, though this is not
necessarily correct when $Math::MPFR::VERSION is less than 3.33 or
the version of perl itself is less than 5.22.
Uses the mpfr library to assign the value represented by $str as a
double or long double or double-double or __float128 (as determined
by the value of $bits). It then returns a hex dump of the bytes that
make up that C data type.
For example, nv_mpfr('1e+127', 53) returns 5a4d8ba7f519c84f.
This is the same as should be returned by
scalar(reverse(unpack("h*", pack("d<", 1e+127))))
except that, on my Windows machine, it returns 5a4d8ba7f519c851 .
(Yes, perl's assignment of that value is out by 2 ULP's.)
For the double-double, the returned scalar is a reference to a list
that contains 2 elements - the hex dump of the most significant
double, and the hex dump of the least siginificant double.
For all other types, the returned scalar contains the hex dump
of the given value.
The enticement to use this function in preference to nv() is
twofold:
1) mpfr reliably sets floating point values correctly (whereas C is
more likely to suffer bugs);
2) nv_mpfr() can provide hex dumps for any of the four data types
(double, long double, double-double and __float128), whereas nv()
returns only the value for whichever data type is specified by
$Config{nvtype}.
Note, however, that for nv_mpfr() to return the hex form of the
__float128 type, the mpfr library (as used by Math::MPFR) needs to have
been built using the configure option --enable-float128, and this
configure option is only available with mpfr-3.2.0 or later.
As is the case with nv(), you'll generally want $str to be a string.
For example, specify the string "2.3", rather than the NV 2.3.
Failure to adhere to this will result in a warning - though you can
disable this warning by setting $Math::NV::no_warn to 1.
$nv_type = nv_type();
Returns "double", "long double", or "__float128" depending upon
the way perl has been configured.
The expectation is that it returns the same as $Config{nvtype}.
(Please file a bug report if you find otherwise.)
$digits = mant_dig();
Returns the number of bits the NV mantissa contains. This is
normally 53 if nv_type() is double - otherwise usually (but by no
means always) 64.
It returns the value of the C macro DBL_MANT_DIG, LDBL_MANT_DIG,
or FLT128_MANT_DIG depending upon whichever is appropriate for
perl's configuration.
($mantissa, $exponent, $precision) = ld2binary($nv);
Uses code taken from tests/tset_ld.c in the mpfr library source
and returns a base 2 representation of the value contained in the
NV $nv - irrespective of whether the NV type ($Config{nvtype}) is
double, long double or __float128.
$mantissa is the mantissa (significand).
$exponent is the exponent.
$precision is the precision (in bits) of the mantissa - trailing
zero bits are not counted.
($mantissa, $exponent, $precision) = ld_str2binary($str);
Uses code taken from tests/tset_ld.c in the mpfr library source
and returns a base 2 representation of the value of the NV
represented by the string $str - irrespective of whether the NV
type ($Config{nvtype}) is double, long double or __float128.
$mantissa is the mantissa (significand).
$exponent is the exponent.
$precision is the precision (in bits) of the mantissa - trailing
zero bits are not counted.
$nv = bin2val($mantissa, $exponent, $precision);
Takes the return values of ld_str2binary() or ld2binary() and
returns the original NV. (Probably doesn't work if the original
NV is an inf or a nan.)
Cprintf($fmt, $nv);
Uses C's printf() function to format the NV $nv, according to the
formatting specified by the string $fmt.
$string = Csprintf($fmt, $nv, $buffer_size);
Uses C's sprintf() function to format the NV $nv, according to the
formatting specified by the string $fmt - and returns the result to
$string. It's the responsibility of the caller to ensure that
$buffer_size specifies a large enough number of characters to
accommodate C's sprintf formatting of $nv.
=head1 PACKAGE VARIABLES
$Math::NV::no_mpfr
At startup, NV.pm runs "eval{require Math::MPFR;};".
$Math::NV::no_mpfr is automatically set to 0 (if Math::MPFR loads)
or to $@ (if Math::MPFR fails to load).
Can subsequently be overwritten by assigning directly to it.
$Math::NV::no_warn
Initially set to 0 - which means that if either nv(), nv_mpfr(),
is_eq() or is_eq_mpfr() are handed an argument that is not a string,
then a warning will be emitted.
To disable this warning, simply assign 1 (or any other true numeric
value) to this variable.
=head1 LICENSE
This program is free software; you may redistribute it and/or modify
it under the same terms as Perl itself.
Copyright 2013-16 Sisyphus
=head1 AUTHOR
Sisyphus <sisyphus at(@) cpan dot (.) org>
=cut