view release on metacpan or  search on metacpan

lib/Data/Float.pm  view on Meta::CPAN

my $have_subnormal;
{
	my $testval = $min_finite * 1.5;
	$have_subnormal = $testval == $min_finite ||
				$testval == ($min_finite + $min_finite);
}

_mk_constant("have_subnormal", $have_subnormal);

my $min_normal_exp = $have_subnormal ?
			$min_finite_exp + $significand_bits :
			$min_finite_exp;
my $min_normal = $have_subnormal ?
			mult_pow2($min_finite, $significand_bits) :
			$min_finite;

_mk_constant("min_normal_exp", $min_normal_exp);
_mk_constant("min_normal", $min_normal);

#
# Feature tests.
#

my $have_signed_zero = sprintf("%e", -0.0) =~ /\A-/;
_mk_constant("have_signed_zero", $have_signed_zero);
my($pos_zero, $neg_zero);
if($have_signed_zero) {
	$pos_zero = +0.0;
	$neg_zero = -0.0;
	my $tzero = -0.0;
	{ no warnings "void"; $tzero == $tzero; }
	my $ntzero = -$tzero;
	if(sprintf("%e", -$ntzero) =~ /\A-/) {
		_mk_constant("pos_zero", $pos_zero);
		_mk_constant("neg_zero", $neg_zero);
	} else {
		# Zeroes lose their signedness upon arithmetic operations.
		# Therefore make the pos_zero and neg_zero functions
		# return fresh zeroes to avoid trouble.
		*pos_zero = sub () { my $ret = $pos_zero };
		*neg_zero = sub () { my $ret = $neg_zero };
		push @EXPORT_OK, "pos_zero", "neg_zero";
	}
}

my($have_infinite, $pos_infinity, $neg_infinity);
{
	my $testval = $max_finite * $max_finite;
	$have_infinite = $testval == $testval && $testval != $max_finite;
	_mk_constant("have_infinite", $have_infinite);
	if($have_infinite) {
		_mk_constant("pos_infinity", $pos_infinity = $testval);
		_mk_constant("neg_infinity", $neg_infinity = -$testval);
	}
}

my $max_number = $have_infinite ? $pos_infinity : $max_finite;
_mk_constant("max_number", $max_number);

my($have_nan, $nan);
foreach my $nan_formula (
		'$have_infinite && $pos_infinity/$pos_infinity',
		'log(-1.0)',
		'0.0/0.0',
		'"nan"') {
	my $maybe_nan =
		eval 'local $SIG{__DIE__}; local $SIG{__WARN__} = sub { }; '.
		     $nan_formula;
	if(do { local $SIG{__WARN__} = sub { }; $maybe_nan != $maybe_nan }) {
		$have_nan = 1;
		$nan = $maybe_nan;
		_mk_constant("nan", $nan);
		last;
	}
}
_mk_constant("have_nan", $have_nan);

# The rest of the code is parsed after the constants have been calculated
# and installed, so that it can benefit from their constancy.
{
	local $/ = undef;
	my $code = <DATA>;
	close(DATA);
	{
		local $SIG{__DIE__};
		eval $code;
	}
	die $@ if $@ ne "";
}

1;

__DATA__

=head1 FUNCTIONS

Each "float_" function takes a floating point argument to operate on.  The
argument must be a native floating point value, or a native integer with
a value that can be represented in floating point.  Giving a non-numeric
argument will cause mayhem.  See L<Params::Classify/is_number> for a way
to check for numericness.  Only the numeric value of the scalar is used;
the string value is completely ignored, so dualvars are not a problem.

=head2 Classification

Each "float_is_" function returns a simple truth value result.

=over

=item float_class(VALUE)

Determines which of the five classes described above VALUE falls
into. Returns "NORMAL", "SUBNORMAL", "ZERO", "INFINITE", or "NAN"
accordingly.

=cut

sub float_class($) {
	my($val) = @_;
	return "ZERO" if $val == 0.0;
	return "NAN" if $val != $val;
	$val = -$val if $val < 0;
	return "INFINITE" if have_infinite && $val == $pos_infinity;
	return have_subnormal && $val < min_normal ? "SUBNORMAL" : "NORMAL";
}

=item float_is_normal(VALUE)