Data-IEEE754-Tools
view release on metacpan or search on metacpan
index; tried a couple of submissions, none of which
really did what I wanted. Will try to move up to next
public release version number (v0.016), and ask PAUSE
to forget the incorrect v0.14001.0 release, and hopefully
re-index to this release.
v0.014 2016-Aug-29
- feature request <https://rt.cpan.org/Ticket/Display.html?id=116155>
+ add many functions
:ulp => ulp, nextUp, nextDown, nextAfter
:info => isSignMinus, isNormal, isFinite, isNaN, isSignaling,
isSignalingConvertedToQuiet, isCanonical, class, radix, totalOrder,
totalOrderMag, compareFloatingValue, compareFloatingMag
:signbit => copy, negate, abs, copySign, isSignMinus
- feature request <https://rt.cpan.org/Ticket/Display.html?id=116154>
+ add :constants
- feature request <https://rt.cpan.org/Ticket/Display.html?id=116153>
+ update ulp() with new, faster method
v0.013
- Odd versions are development versions, used for developing and verifying
POS_SNAN_FIRST POS_SNAN_LAST
POS_IND POS_QNAN_FIRST POS_QNAN_LAST
NEG_ZERO
NEG_DENORM_SMALLEST NEG_DENORM_BIGGEST
NEG_NORM_SMALLEST NEG_NORM_BIGGEST
NEG_INF
NEG_SNAN_FIRST NEG_SNAN_LAST
NEG_IND NEG_QNAN_FIRST NEG_QNAN_LAST
);
my @EXPORT_INFO = qw(isSignMinus isNormal isFinite isZero isSubnormal
isInfinite isNaN isSignaling isSignalingConvertedToQuiet isCanonical
class radix totalOrder totalOrderMag compareFloatingValue compareFloatingMag);
my @EXPORT_SIGNBIT = qw(copy negate abs copySign isSignMinus);
our @EXPORT_OK = (@EXPORT_FLOATING, @EXPORT_RAW754, @EXPORT_ULP, @EXPORT_CONST, @EXPORT_INFO, @EXPORT_SIGNBIT);
our %EXPORT_TAGS = (
floating => [@EXPORT_FLOATING],
floatingpoint => [@EXPORT_FLOATING],
raw754 => [@EXPORT_RAW754],
ulp => [@EXPORT_ULP],
constants => [@EXPORT_CONST],
# : :
# : `- fraction
# :
# `- sign+exponent
The first three nibbles (hexadecimal digits) encode the sign and the exponent. The sign is
the most significant bit of the three nibbles (so AND the first nibble with 8; if it's true,
the number is negative, else it's positive). The remaining 11 bits of the nibbles encode the
exponent: convert the 11bits to decimal, then subtract 1023. If the resulting exponent is -1023,
it indicates a zero or denormal value; if the exponent is +1024, it indicates an infinite (Inf) or
not-a-number (NaN) value, which are generally used to indicate the calculation has grown to large
to fit in an IEEE754 double (Inf) or has tried an performed some other undefined operation (divide
by zero or the logarithm of a zero or negative value) (NaN).
The final thirteen nibbles are the encoding of the fractional value (usually C<1 + thirteennibbles /
16**13>, unless it's zero, denormal, infinite, or not a number).
Of course, this is easier to decode using the L</to_dec_floatingpoint()> function, which interprets
the sign, fraction, and exponent for you. (See below for more details.)
to_dec_floatingpoint(12.875); # +0d1.6093750000000000p+0003
# ^ ^^^^^^^^^^^^^^^^^^ ^^^^
# : : :
NEG_DENORM_BIGGEST # -0x0.fffffffffffffp-1022 # largest negative value that requires denormal representation in 64bit floating-point
NEG_NORM_SMALLEST # -0x1.0000000000000p-1022 # smallest negative value that allows for normal representation in 64bit floating-point
NEG_NORM_BIGGEST # -0x1.fffffffffffffp+1023 # largest negative value that allows for normal representation in 64bit floating-point
NEG_INF # -0x1.#INF000000000p+0000 # negative infinity: indicates that the answer is out of the range of a 64bit floating-point
NEG_SNAN_FIRST # -0x1.#SNAN00000000p+0000 # negative signaling NAN with "0x0000000000001" as the system-dependent information [*]
NEG_SNAN_LAST # -0x1.#SNAN00000000p+0000 # negative signaling NAN with "0x7FFFFFFFFFFFF" as the system-dependent information [*]
NEG_IND # -0x1.#IND000000000p+0000 # negative quiet NAN with "0x8000000000000" as the system-dependent information [%]
NEG_QNAN_FIRST # -0x1.#QNAN00000000p+0000 # negative quiet NAN with "0x8000000000001" as the system-dependent information
NEG_QNAN_LAST # -0x1.#QNAN00000000p+0000 # negative quiet NAN with "0xFFFFFFFFFFFFF" as the system-dependent information
[*] note that many perl interpreters will internally convert Signalling NaN (SNAN) to Quiet NaN (QNAN)
[%] some perl interpreters define the zeroeth negative Quiet NaN, NEG_IND, as an "indeterminate" value (IND);
in a symmetrical world, they would also define the zeroeth positive Quiet NaN, POS_IND, as an "indeterminate" value (IND)
=cut
{ my $local; sub POS_ZERO () { $local = hexstr754_to_double('000'.'0000000000000') unless defined $local; return $local; } }
{ my $local; sub POS_DENORM_SMALLEST() { $local = hexstr754_to_double('000'.'0000000000001') unless defined $local; return $local; } }
{ my $local; sub POS_DENORM_BIGGEST () { $local = hexstr754_to_double('000'.'FFFFFFFFFFFFF') unless defined $local; return $local; } }
{ my $local; sub POS_NORM_SMALLEST () { $local = hexstr754_to_double('001'.'0000000000000') unless defined $local; return $local; } }
{ my $local; sub POS_NORM_BIGGEST () { $local = hexstr754_to_double('7FE'.'FFFFFFFFFFFFF') unless defined $local; return $local; } }
{ my $local; sub POS_INF () { $local = hexstr754_to_double('7FF'.'0000000000000') unless defined $local; return $local; } }
{ my $local; sub POS_SNAN_FIRST () { $local = hexstr754_to_double('7FF'.'0000000000001') unless defined $local; return $local; } }
=head3 nextAfter( I<value>, I<direction> )
Returns the next floating point value after I<value> in the direction of I<direction>. If the
two are identical, return I<direction>; if I<direction> is numerically above I<float>, return
C<nextUp(I<value>)>; if I<direction> is numerically below I<float>, return C<nextDown(I<value>)>.
=cut
sub nextAfter {
return $_[0] if $_[0] != $_[0]; # return value when value is NaN
return $_[1] if $_[1] != $_[1]; # return direction when direction is NaN
return $_[1] if $_[1] == $_[0]; # return direction when the two are equal
return nextUp($_[0]) if $_[1] > $_[0]; # return nextUp if direction > value
return nextDown($_[0]); # otherwise, return nextDown()
}
=head2 :info
The informational functions include various operations (defined in 754-2008 #5.7.2) that provide general
information about the floating-point value: most define whether a value is a special condition of
floating-point or not (such as normal, finite, zero, ...).
=head3 isSignMinus( I<value> )
Returns 1 if I<value> has negative sign (even applies to zeroes and NaNs); otherwise, returns 0.
=cut
sub isSignMinus {
# look at leftmost nibble, and determine whether it has the 8-bit or not (which is the sign bit)
return (hex(substr(hexstr754_from_double(shift),0,1)) & 8) >> 3;
}
=head3 isNormal( I<value> )
Returns 1 if I<value> is a normal number (not zero, subnormal, infinite, or NaN); otherwise, returns 0.
=cut
sub isNormal {
# it's normal if the leftmost three nibbles (excluding sign bit) are not 000 or 7FF
my $exp = hex(substr(hexstr754_from_double(shift),0,3)) & 0x7FF;
return (0 < $exp) && ($exp < 0x7FF) || 0;
}
=head3 isFinite( I<value> )
Returns 1 if I<value> is a finite number (zero, subnormal, or normal; not infinite or NaN); otherwise, returns 0.
=cut
sub isFinite {
# it's finite if the leftmost three nibbles (excluding sign bit) are not 7FF
my $exp = hex(substr(hexstr754_from_double(shift),0,3)) & 0x7FF;
return ($exp < 0x7FF) || 0;
}
=head3 isZero( I<value> )
=cut
sub isZero {
# it's zero if it's 0x[80]000000000000000
my $str = substr(hexstr754_from_double(shift),1,15);
return ($str eq '0'x15) || 0;
}
=head3 isSubnormal( I<value> )
Returns 1 if I<value> is subnormal (not zero, normal, infinite, nor NaN); otherwise, returns 0.
=cut
sub isSubnormal {
# it's subnormal if it's 0x[80]00___ and the last 13 digits are not all zero
my $h = hexstr754_from_double(shift);
my $exp = substr($h,0,3);
my $frc = substr($h,3,13);
return ($exp eq '000' || $exp eq '800') && ($frc ne '0'x13) || 0;
}
=head3 isInfinite( I<value> )
Returns 1 if I<value> is positive or negative infinity (not zero, subnormal, normal, nor NaN); otherwise, returns 0.
=cut
sub isInfinite {
# it's infinite if it's 0x[F7]FF_0000000000000
my $h = hexstr754_from_double(shift);
my $exp = substr($h,0,3);
my $frc = substr($h,3,13);
return ($exp eq '7FF' || $exp eq 'FFF') && ($frc eq '0'x13) || 0;
}
=head3 isNaN( I<value> )
Returns 1 if I<value> is NaN (not zero, subnormal, normal, nor infinite); otherwise, returns 0.
=cut
sub isNaN {
# it's infinite if it's 0x[F7]FF_0000000000000
my $h = hexstr754_from_double(shift);
my $exp = substr($h,0,3);
my $frc = substr($h,3,13);
return ($exp eq '7FF' || $exp eq 'FFF') && ($frc ne '0'x13) || 0;
}
=head3 isSignaling( I<value> )
Returns 1 if I<value> is a signaling NaN (not zero, subnormal, normal, nor infinite), otherwise, returns 0.
Note that some perl implementations convert some or all signaling NaNs to quiet NaNs, in which case,
C<isSignaling> might return only 0.
=cut
sub isSignaling {
# it's signaling if isNaN and MSB of fractional portion is 1
my $h = hexstr754_from_double(shift);
my $exp = substr($h,0,3);
my $frc = substr($h,3,13);
my $qbit = (0x8 && hex(substr($h,3,1))) >> 3; # 1: quiet, 0: signaling
return ($exp eq '7FF' || $exp eq 'FFF') && ($frc ne '0'x13) && (!$qbit) || 0; # v0.013_007 = possible coverage bug: don't know whether it's the paren or non-paren, but the "LEFT=TRUE" condition of "OR 2 CONDITIONS" is never covered
}
=head4 isSignalingConvertedToQuiet()
Returns 1 if your implementation of perl converts a SignalingNaN to a QuietNaN, otherwise returns 0.
This is I<not> a standard IEEE 754 function; but this is used to determine if the C<isSignaling()>
function is meaningful in your implementation of perl.
=cut
sub isSignalingConvertedToQuiet {
!isSignaling( POS_SNAN_FIRST ) || 0 # v0.013 coverage note: ignore Devel::Cover failures on this line
}
I<value>s seem canonical, and thus return 1.
=cut
sub isCanonical { 1 }
=head3 class( I<value> )
Returns the "class" of the I<value>:
signalingNaN
quietNaN
negativeInfinity
negativeNormal
negativeSubnormal
negativeZero
positiveZero
positiveSubnormal
positiveNormal
positiveInfinity
=cut
sub class {
return 'signalingNaN' if isSignaling($_[0]); # v0.013 coverage note: ignore Devel::Cover failures on this line (won't return on systems that quiet SNaNs
return 'quietNaN' if isNaN($_[0]);
return 'negativeInfinity' if isInfinite($_[0]) && isSignMinus($_[0]);
return 'negativeNormal' if isNormal($_[0]) && isSignMinus($_[0]);
return 'negativeSubnormal' if isSubnormal($_[0]) && isSignMinus($_[0]);
return 'negativeZero' if isZero($_[0]) && isSignMinus($_[0]);
return 'positiveZero' if isZero($_[0]) && !isSignMinus($_[0]); # v0.013 coverage note: ignore Devel::Cover->CONDITION failure; alternate condition already returned above
return 'positiveSubnormal' if isSubnormal($_[0]) && !isSignMinus($_[0]); # v0.013 coverage note: ignore Devel::Cover->CONDITION failure; alternate condition already returned above
return 'positiveNormal' if isNormal($_[0]) && !isSignMinus($_[0]); # v0.013 coverage note: ignore Devel::Cover->CONDITION failure; alternate condition already returned above
return 'positiveInfinity' if isInfinite($_[0]) && !isSignMinus($_[0]); # v0.013 coverage note: no tests for FALSE because all conditions covered above
}
=cut
sub radix { 2 }
=head3 totalOrder( I<x>, I<y> )
Returns TRUE if I<x> E<le> I<y>, FALSE if I<x> E<gt> I<y>.
Special cases are ordered as below:
-quietNaN < -signalingNaN < -infinity < ...
... < -normal < -subnormal < -zero < ...
... < +zero < +subnormal < +normal < ...
... < +infinity < +signalingNaN < +quietNaN
=cut
sub totalOrder {
my ($x, $y) = @_[0,1];
my ($bx,$by) = map { binstr754_from_double($_) } $x, $y; # convert to binary strings
my @xsegs = ($bx =~ /(.)(.{11})(.{20})(.{32})/); # split into sign, exponent, MSB, LSB
my @ysegs = ($by =~ /(.)(.{11})(.{20})(.{32})/); # split into sign, exponent, MSB, LSB
my ($xin, $yin) = map { isNaN($_) } $x, $y; # determine if NaN: used twice each, so save the values rather than running twice each during if-switch
if( $xin && $yin ) { # BOTH NaN
# use a trick: the rules for both-NaN treat it as if it's just another floating point,
# so lie about the exponent and do a normal comparison
($bx, $by) = map { $_->[1] = '1' . '0'x10; join '', @$_ } \@xsegs, \@ysegs;
($x, $y) = map { binstr754_to_double($_) } $bx, $by;
return (($x <= $y) || 0);
} elsif ( $xin ) { # just x NaN: TRUE if x is NEG
return ( ($xsegs[0]) || 0 );
} elsif ( $yin ) { # just y NaN: TRUE if y is not NEG
return ( (!$ysegs[0]) || 0 );
} elsif ( isZero($x) && isZero($y) ) { # both zero: TRUE if x NEG, or if x==y
# trick = -signbit(x) <= -signbit(y), since signbit is 1 for negative, -signbit = -1 for negative
return ( (-$xsegs[0] <= -$ysegs[0]) || 0 );
} else { # numeric comparison (works for inf, normal, subnormal, or only one +/-zero)
return( ($x <= $y) || 0 );
}
}
=head3 totalOrderMag( I<x>, I<y> )
Returns TRUE if I<abs(x)> E<le> I<abs(y)>, otherwise FALSE.
Equivalent to
totalOrder( abs(x), abs(y) )
Special cases are ordered as below:
zero < subnormal < normal < infinity < signalingNaN < quietNaN
=cut
sub totalOrderMag {
my ($x, $y) = @_[0,1];
my ($bx,$by) = map { binstr754_from_double($_) } $x, $y; # convert to binary strings
($x, $y) = map { substr $_, 0, 1, '0'; binstr754_to_double($_) } $bx, $by; # set sign bit to 0, and convert back to number
return totalOrder( $x, $y ); # compare normally
}
=head3 compareFloatingValue( I<x>, I<y> )
=head3 compareFloatingMag( I<x>, I<y> )
These are similar to C<totalOrder()> and C<totalOrderMag()>, except they return
-1 for C<x E<lt> y>, 0 for C<x == y>, and +1 for C<x E<gt> y>.
These are not in IEEE 754-2008, but are included as functions to replace the perl spaceship
(C<E<lt>=E<gt>>) when comparing floating-point values that might be NaN.
=cut
sub compareFloatingValue {
my ($x, $y) = @_[0,1];
my ($bx,$by) = map { binstr754_from_double($_) } $x, $y; # convert to binary strings
my @xsegs = ($bx =~ /(.)(.{11})(.{20})(.{32})/); # split into sign, exponent, MSB, LSB
my @ysegs = ($by =~ /(.)(.{11})(.{20})(.{32})/); # split into sign, exponent, MSB, LSB
my ($xin, $yin) = map { isNaN($_) } $x, $y; # determine if NaN: used twice each, so save the values rather than running twice each during if-switch
if( $xin && $yin ) { # BOTH NaN
# use a trick: the rules for both-NaN treat it as if it's just another floating point,
# so lie about the exponent and do a normal comparison
($bx, $by) = map { $_->[1] = '1' . '0'x10; join '', @$_ } \@xsegs, \@ysegs;
($x, $y) = map { binstr754_to_double($_) } $bx, $by;
return ($x <=> $y);
} elsif ( $xin ) { # just x NaN: if isNaN(x) && isNegative(x) THEN -1 (x<y) ELSE (x>y)
return ( ($xsegs[0])*-1 || +1 );
} elsif ( $yin ) { # just y NaN: if isNaN(y) && !isNegative(y) THEN -1 (x<y) ELSE (x>y)
return ( (!$ysegs[0])*-1 || +1 );
} elsif ( isZero($x) && isZero($y) ) { # both zero: TRUE if x NEG, or if x==y
# trick = -signbit(x) <=> -signbit(y), since signbit is 1 for negative, -signbit = -1 for negative
return (-$xsegs[0] <=> -$ysegs[0]);
} else { # numeric comparison (works for inf, normal, subnormal, or only one +/-zero)
return ($x <=> $y);
}
}
sub compareFloatingMag {
return compareFloatingValue( $x, $y ); # compare normally
}
=head2 :signbit
These functions, from IEEE Std 754-2008, manipulate the sign bits
of the argument(s)set P.
See IEEE Std 754-2008 #5.5.1 "Sign bit operations": This section asserts
that the sign bit operations (including C<negate>, C<abs>, and C<copySign>)
should only affect the sign bit, and should treat numbers and NaNs alike.
=head3 copy( I<value> )
Copies the I<value> to the output, leaving the sign bit unchanged, for all
numbers and NaNs.
=cut
sub copy {
return shift;
}
=head3 negate( I<value> )
Reverses the sign bit of I<value>. (If the sign bit is set on I<value>,
it will not be set on the output, and vice versa; this will work on
signed zeroes, on infinities, and on NaNs.)
=cut
sub negate {
my $b = binstr754_from_double(shift); # convert to binary string
my $s = 1 - substr $b, 0, 1; # toggle sign
substr $b, 0, 1, $s; # replace sign
return binstr754_to_double($b); # convert to floating-point
}
=head3 abs( I<value> )
Similar to the C<CORE::abs()> builtin function, C<abs()> is provided as a
module-based function to get the absolute value (magnitude) of a 64bit
floating-point number.
The C<CORE::abs()> function behaves properly (per the IEEE 754 description)
for all classes of I<value>, except that many implementations do not correctly
handle -NaN properly, outputting -NaN, which is in violation of the standard.
The C<Data::IEEE754::Tools::abs()> function correctly treats NaNs in the same
way it treats numerical values, and clears the sign bit on the output.
Please note that exporting C<abs()> or C<:signbit> from this module will
"hide" the builtin C<abs()> function. If you really need to use the builtin
version (for example, you care more about execution speed than its ability to find
the absolute value of a signed NaN), then you may call it as C<CORE::abs>.
=cut
sub abs {
my $b = binstr754_from_double(shift); # convert to binary string
substr $b, 0, 1, '0'; # replace sign
return binstr754_to_double($b); # convert to floating-point
}
=head3 copySign( I<x>, I<y> )
=over
=item * L<What Every Compute Scientist Should Know About Floating-Point Arithmetic|https://docs.oracle.com/cd/E19957-01/806-3568/ncg_goldberg.html>
=item * L<Perlmonks: Integers sometimes turn into Reals after substraction|http://perlmonks.org/?node_id=1163025> for
inspiring me to go down the IEEE754-expansion trail in perl.
=item * L<Perlmonks: Exploring IEEE754 floating point bit patterns|http://perlmonks.org/?node_id=984141> as a resource
for how perl interacts with the various "edge cases" (+/-infinity, L<denormalized numbers|https://en.wikipedia.org/wiki/Denormal_number>,
signaling and quiet L<NaNs (Not-A-Number)|https://en.wikipedia.org/wiki/NaN>.
=item * L<Data::IEEE754>: I really wanted to use this module, but it didn't get me very far down the "Tools" track,
and included a lot of overhead modules for its install/test that I didn't want to require for B<Data::IEEE754::Tools>.
However, I was inspired by his byteorder-dependent anonymous subs (which were in turn derived from L<Data::MessagePack::PP>);
they were more efficient, on a per-call-to-subroutine basis, than my original inclusion of the if(byteorder) in every call to
the sub.
=item * L<Data::Float>: Similar to this module, but uses numeric manipulation.
=back
t/07-info.t view on Meta::CPAN
use Data::IEEE754::Tools qw/:raw754 :floatingpoint :constants :info/;
my @tests = ();
# [CONSTANT , 'NAME ', -, N, F, Z, s, I, !, S, C, 'class' , R];
push @tests, [POS_ZERO , 'POS_ZERO ', 0, 0, 1, 1, 0, 0, 0, 0, 1, 'positiveZero' , 2];
push @tests, [POS_DENORM_SMALLEST, 'POS_DENORM_SMALLEST', 0, 0, 1, 0, 1, 0, 0, 0, 1, 'positiveSubnormal', 2];
push @tests, [POS_DENORM_BIGGEST , 'POS_DENORM_BIGGEST ', 0, 0, 1, 0, 1, 0, 0, 0, 1, 'positiveSubnormal', 2];
push @tests, [POS_NORM_SMALLEST , 'POS_NORM_SMALLEST ', 0, 1, 1, 0, 0, 0, 0, 0, 1, 'positiveNormal' , 2];
push @tests, [POS_NORM_BIGGEST , 'POS_NORM_BIGGEST ', 0, 1, 1, 0, 0, 0, 0, 0, 1, 'positiveNormal' , 2];
push @tests, [POS_INF , 'POS_INF ', 0, 0, 0, 0, 0, 1, 0, 0, 1, 'positiveInfinity' , 2];
push @tests, [POS_SNAN_FIRST , 'POS_SNAN_FIRST ', 0, 0, 0, 0, 0, 0, 1, 1, 1, 'signalingNaN' , 2];
push @tests, [POS_SNAN_LAST , 'POS_SNAN_LAST ', 0, 0, 0, 0, 0, 0, 1, 1, 1, 'signalingNaN' , 2];
push @tests, [POS_IND , 'POS_IND ', 0, 0, 0, 0, 0, 0, 1, 0, 1, 'quietNaN' , 2];
push @tests, [POS_QNAN_FIRST , 'POS_QNAN_FIRST ', 0, 0, 0, 0, 0, 0, 1, 0, 1, 'quietNaN' , 2];
push @tests, [POS_QNAN_LAST , 'POS_QNAN_LAST ', 0, 0, 0, 0, 0, 0, 1, 0, 1, 'quietNaN' , 2];
push @tests, [NEG_ZERO , 'NEG_ZERO ', 1, 0, 1, 1, 0, 0, 0, 0, 1, 'negativeZero' , 2];
push @tests, [NEG_DENORM_SMALLEST, 'NEG_DENORM_SMALLEST', 1, 0, 1, 0, 1, 0, 0, 0, 1, 'negativeSubnormal', 2];
push @tests, [NEG_DENORM_BIGGEST , 'NEG_DENORM_BIGGEST ', 1, 0, 1, 0, 1, 0, 0, 0, 1, 'negativeSubnormal', 2];
push @tests, [NEG_NORM_SMALLEST , 'NEG_NORM_SMALLEST ', 1, 1, 1, 0, 0, 0, 0, 0, 1, 'negativeNormal' , 2];
push @tests, [NEG_NORM_BIGGEST , 'NEG_NORM_BIGGEST ', 1, 1, 1, 0, 0, 0, 0, 0, 1, 'negativeNormal' , 2];
push @tests, [NEG_INF , 'NEG_INF ', 1, 0, 0, 0, 0, 1, 0, 0, 1, 'negativeInfinity' , 2];
push @tests, [NEG_SNAN_FIRST , 'NEG_SNAN_FIRST ', 1, 0, 0, 0, 0, 0, 1, 1, 1, 'signalingNaN' , 2];
push @tests, [NEG_SNAN_LAST , 'NEG_SNAN_LAST ', 1, 0, 0, 0, 0, 0, 1, 1, 1, 'signalingNaN' , 2];
push @tests, [NEG_IND , 'NEG_IND ', 1, 0, 0, 0, 0, 0, 1, 0, 1, 'quietNaN' , 2];
push @tests, [NEG_QNAN_FIRST , 'NEG_QNAN_FIRST ', 1, 0, 0, 0, 0, 0, 1, 0, 1, 'quietNaN' , 2];
push @tests, [NEG_QNAN_LAST , 'NEG_QNAN_LAST ', 1, 0, 0, 0, 0, 0, 1, 0, 1, 'quietNaN' , 2];
my @flist = qw(isSignMinus isNormal isFinite isZero isSubnormal isInfinite isNaN isSignaling isCanonical class radix);
plan tests => scalar(@tests) * scalar(@flist);
my $skip_reason = '';
if( isSignalingConvertedToQuiet() ) {
$skip_reason = 'Signaling NaN are converted to QuietNaN by your perl: ';
eval { require Config };
$skip_reason .= $@ ? sprintf('v%vd',$^V) : "$Config::Config{myuname}";
}
foreach my $t ( @tests ) {
my ($c, $name, @x) = @$t;
my $mi = (@flist >= @x) ? $#flist : $#x;
foreach my $i ( 0 .. $mi ) {
my $fn = $flist[$i];
my $xi = $x[$i];
my $f = \&{$fn};
SKIP: { # allows for skipping isSignaling() tests.
skip sprintf('%-15.15s(%-20.20s): %s', $fn, $name, $skip_reason), 1 if( ( ($fn eq 'isSignaling') || ($xi eq 'signalingNaN') ) && isSignalingConvertedToQuiet() );
cmp_ok( $f->($c), 'eq', $xi, sprintf('%-20.20s(%-20.20s)', $fn, $name ) );
}
}
}
exit;
t/08-totalorder.t view on Meta::CPAN
sub ijSignal($) { # hardcoded indexes of the array; if array changes, must change indexes
local $_ = shift;
/^(3|4|17|18)$/
}
plan tests => (scalar @constants)**2 * 4;
my $skip_reason = '';
if( isSignalingConvertedToQuiet() ) {
$skip_reason = 'Signaling NaN are converted to QuietNaN by your perl: ';
eval { require Config };
$skip_reason .= $@ ? sprintf('v%vd',$^V) : "$Config::Config{myuname}";
}
sub habs($) {
my $h = shift;
my $s = substr $h, 0, 1;
$s = sprintf '%1.1X', (hex($s)&0x7); # mask OUT sign bit
substr $h, 0, 1, $s;
return $h;
t/08-totalorder.t view on Meta::CPAN
my $hax = habs($hx);
my $ax = hexstr754_to_double($hax);
foreach my $j (0 .. $#constants) {
my $y = $constants[$j];
my $hy = hexstr754_from_double($y);
my $hay = habs($hy);
my $ay = hexstr754_to_double($hay);
local $, = ", ";
local $\ = "\n";
my $skip_bool = isSignalingConvertedToQuiet() && (
# if Signalling converted to Quiet, order will be messed up if both are NaN but one each of signal and quiet
(ijQuiet($i) && ijSignal($j)) || # i quiet && j signaling
(ijQuiet($j) && ijSignal($i)) # j quiet && i signaling
);
# totalOrder(x,y): x<=y ? 1 : 0;
SKIP: {
skip sprintf('%-25.25s(%16.16s,%16.16s): %s','totalOrder',$hx,$hy,$skip_reason), 1 if $skip_bool;
# this will still compare either NaN to anything else (INF, NORM, SUB, ZERO), and will also compare
# signaling to signaling and quiet to quiet
my $got = totalOrder( $x, $y );
my $exp = ($i <= $j) || 0;
is( $got, $exp, sprintf('%-30.30s(%s,%s)', 'totalOrder', $hx, $hy ) );
}
# totalOrderMag(x,y): |x|<=|y| ? 1 : 0;
SKIP: {
skip sprintf('%-25.25s(%16.16s,%16.16s): %s','totalOrderMag',$hax,$hay,$skip_reason), 1 if $skip_bool;
# this will still compare either NaN to anything else (INF, NORM, SUB, ZERO), and will also compare
# signaling to signaling and quiet to quiet
my $got = totalOrderMag( $x, $y );
my $exp = ( ($i<11 ? 21-$i : $i) <= ($j<11 ? 21-$j : $j) ) || 0;
is( $got, $exp, sprintf('%-30.30s(%s,%s)', 'totalOrderMag', $hax, $hay ) );
}
# compareFloatingValue(x,y): x <=> y
SKIP: {
skip sprintf('%-25.25s(%16.16s,%16.16s): %s','compareFloatingValue',$hx,$hy,$skip_reason), 1 if $skip_bool;
# this will still compare either NaN to anything else (INF, NORM, SUB, ZERO), and will also compare
# signaling to signaling and quiet to quiet
my $got = compareFloatingValue( $x, $y );
my $exp = ($i <=> $j);
is( $got, $exp, sprintf('%-30.30s(%s,%s)', 'compareFloatingValue', $hx, $hy ) );
}
# compareFloatingMag(x,y): |x| <=> |y|
SKIP: {
skip sprintf('%-25.25s(%16.16s,%16.16s): %s','compareFloatingMag',$hax,$hay,$skip_reason), 1 if $skip_bool;
# this will still compare either NaN to anything else (INF, NORM, SUB, ZERO), and will also compare
# signaling to signaling and quiet to quiet
my $got = compareFloatingMag( $x, $y );
my $exp = ($i<11 ? 21-$i : $i) <=> ($j<11 ? 21-$j : $j);
is( $got, $exp, sprintf('%-30.30s(%s,%s)', 'compareFloatingMag', $hax, $hay ) );
}
}
}
( run in 0.274 second using v1.01-cache-2.11-cpan-4d50c553e7e )