File Coverage

blib/lib/MarpaX/Languages/ECMAScript/AST/Grammar/ECMAScript_262_5/StringNumericLiteral/NativeNumberSemantics.pm

Criterion	Covered	Total	%
statement	18	145	12.4
branch	0	58	0.0
condition	0	23	0.0
subroutine	6	51	11.7
pod	45	45	100.0
total	69	322	21.4

use strict;
use warnings FATAL => 'all';

package MarpaX::Languages::ECMAScript::AST::Grammar::ECMAScript_262_5::StringNumericLiteral::NativeNumberSemantics;
use Data::Float qw/have_signed_zero have_infinite have_nan/;
use Math::BigFloat;
use Scalar::Util qw/blessed/;
use Scalar::Util::Numeric qw/isinf isnan/;

our $POS_ZERO = have_signed_zero() ? Data::Float::pos_zero()     : 0;
our $NEG_ZERO = have_signed_zero() ? Data::Float::neg_zero()     : 0;
our $POS_INF  = have_infinite()    ? Data::Float::pos_infinity() : Math::BigFloat->binf();
our $NEG_INF  = have_infinite()    ? Data::Float::neg_infinity() : Math::BigFloat->binf('-');
our $POS_ONE  = +1;
our $NEG_ONE  = -1;
our $NAN      = have_nan()         ? Data::Float::nan()          : Math::BigFloat->bnan();
our $UNDEF    = undef;

# ABSTRACT: ECMAScript 262, Edition 5, lexical string numeric grammar default semantics package, using native perl representations

our $VERSION = '0.018'; # VERSION



sub new {
  my ($class, %opts) = @_;
  my $self = {_number => $opts{number}    // 0,
              _length => $opts{length}    // 0,
              _decimal => $opts{decimal } // 0};
  bless($self, $class);
  return $self;
}


sub clone_init {
  my ($self) = @_;
  return (ref $self)->new();
}


sub clone {
  my ($self) = @_;
  return (ref $self)->new(number => $self->{_number}, length => $self->{_length}, decimal => $self->{_decimal});
}


sub decimalOn {
    $_[0]->{_decimal} = 1;
    return $_[0];
}


sub mul {
    $_[0]->{_number} *= $_[1]->{_number};
    return $_[0];
}


sub div {
    $_[0]->{_number} /= $_[1]->{_number};
    return $_[0];
}


sub mod {
    $_[0]->{_number} %= $_[1]->{_number};
    return $_[0];
}


sub nan {
    $_[0]->{_number} = $NAN;
    return $_[0];
}


sub pos_one {
    $_[0]->{_number} = $POS_ONE;
    return $_[0];
}


sub neg_one {
    $_[0]->{_number} = $NEG_ONE;
    return $_[0];
}


sub pos_zero {
    $_[0]->{_number} = $POS_ZERO;
    return $_[0];
}


sub neg_zero {
    $_[0]->{_number} = $NEG_ZERO;
    return $_[0];
}


sub pos_inf {
    $_[0]->{_number} = $POS_INF;
    return $_[0];
}


sub neg_inf {
    $_[0]->{_number} = $NEG_INF;
    return $_[0];
}


sub pow {
    $_[0]->{_number} **= $_[1]->{_number};
    return $_[0];
}


sub and {
    $_[0]->{_number} &= $_[1]->{_number};
    return $_[0];
}


sub or {
    $_[0]->{_number} |= $_[1]->{_number};
    return $_[0];
}


sub xor {
    $_[0]->{_number} ^= $_[1]->{_number};
    return $_[0];
}


sub not {
    $_[0]->{_number} = ~$_[0]->{_number};
    return $_[0];
}


sub sqrt {
    my $x = eval {sqrt($_[0]->{_number})};
    if ($@) {
      return $_[0]->nan();
    }
    return $_[0];
}


sub left_shift {
    $_[0]->{_number} <<= $_[1]->{_number};
    return $_[0];
}


sub right_shift {
    $_[0]->{_number} >>= $_[1]->{_number};
    return $_[0];
}


sub inc {
    $_[0]->{_number} += 1;
    return $_[0];
}


sub dec {
    $_[0]->{_number} -= 1;
    return $_[0];
}


sub int {
    $_[0]->{_number} = CORE::int("$_[1]");
    $_[0]->{_length} = length("$_[1]");
    return $_[0];
}


sub hex {
    $_[0]->{_number} = CORE::hex("$_[1]");
    return $_[0];
}


sub neg {
    $_[0]->{_number} *= -1;
    return $_[0];
}


sub abs {
    $_[0]->{_number} = CORE::abs($_[0]->{_number});
    return $_[0];
}


sub new_from_sign {
  if ($_[0]->is_nan) {
    return $_[0]->clone_init->nan;
  }
  elsif ($_[0]->is_pos) {
    return $_[0]->clone_init->pos_one;
  }
  else {
    return $_[0]->clone_init->neg_one;
  }
}


sub new_from_cmp {
  if ($_[0]->is_nan || $_[1]->is_nan) {
    return $_[0]->clone_init->nan;
  }
  else {
    my $tmp = $_[0]->clone->sub($_[1]);
    if ($tmp->is_zero) {
      return $_[0]->clone_init->pos_zero;
    }
    elsif ($tmp->is_neg) {
      return $_[0]->clone_init->neg_one;
    }
    else {
      return $_[0]->clone_init->pos_one;
    }
  }
}


sub add {
    $_[0]->{_number} += $_[1]->{_number};
    return $_[0];
}


sub sub {
    $_[0]->{_number} -= $_[1]->{_number};
    return $_[0];
}


sub inc_length {
    ++$_[0]->{_length};
    return $_[0];
}


sub new_from_length {
    return $_[0]->clone_init->int("$_[0]->{_length}");
}


sub sign {
  if ($_[0]->is_zero) {
    return 0;
  }
  elsif ($_[0]->is_pos) {
    return 1;
  }
  elsif ($_[0]->is_neg) {
    return -1;
  }
  else {
    return undef;
  }
}


sub cmp {
    return $_[0]->new_from_cmp($_[1])->sign;
}


sub host_number {
  return $_[0]->{_number};
}


sub host_value {
  #
  # This is native implementation, i.e. we assume that the Math and/or CPUs under the hood
  # are already IEEE-754 compliant, including rounding.
  #
  # This mean that we return internal number as is.
  #
  return $_[0]->{_number};
}


sub is_zero {
    my $blessed = blessed($_[0]->{_number}) || '';
    if (! $blessed) {
	#
	# float_is_zero never fails
	#
	return Data::Float::float_is_zero($_[0]->{_number});
    } elsif ($_[0]->{_number}->can('is_zero')) {
	return $_[0]->{_number}->is_zero();
    } else {
	return $UNDEF;
    }
}


sub is_pos_one {
    my $blessed = blessed($_[0]->{_number}) || '';
    if (! $blessed) {
	return ($_[0]->{_number} == $POS_ONE) ? 1 : 0;
    } elsif ($_[0]->{_number}->can('is_one')) {
	return $_[0]->{_number}->is_one();
    } else {
	return $UNDEF;
    }
}


sub is_neg_one {
    my $blessed = blessed($_[0]->{_number}) || '';
    if (! $blessed) {
	return ($_[0]->{_number} == $NEG_ONE) ? 1 : 0;
    } elsif ($_[0]->{_number}->can('is_one')) {
	return $_[0]->{_number}->is_one('-');
    } else {
	return $UNDEF;
    }
}


sub is_pos {
    my $blessed = blessed($_[0]->{_number}) || '';
    if (! $blessed) {
      if ($_[0]->is_nan) {
        return 0;
      } else {
        return (Data::Float::signbit($_[0]->{_number}) == 0) ? 1 : 0;
      }
    } elsif ($_[0]->{_number}->can('is_pos')) {
	return $_[0]->{_number}->is_pos();
    } else {
	return $UNDEF;
    }
}


sub is_neg {
    my $blessed = blessed($_[0]->{_number}) || '';
    if (! $blessed) {
      if ($_[0]->is_nan) {
        return 0;
      } else {
        return (Data::Float::signbit($_[0]->{_number}) == 0) ? 0 : 1;
      }
    } elsif ($_[0]->{_number}->can('is_neg')) {
	return $_[0]->{_number}->is_neg();
    } else {
	return $UNDEF;
    }
}


sub is_inf {
    my $blessed = blessed($_[0]->{_number}) || '';
    if (! $blessed) {
	#
	# isinf() never fails
	#
	return isinf($_[0]->{_number});
    } elsif ($_[0]->{_number}->can('is_inf')) {
	return $_[0]->{_number}->is_inf();
    } else {
	return $UNDEF;
    }
}


sub is_nan {
    my $blessed = blessed($_[0]->{_number}) || '';
    if (! $blessed) {
	#
	# isnan() never fails
	#
	return isnan($_[0]->{_number});
    } elsif ($_[0]->{_number}->can('is_nan')) {
	return $_[0]->{_number}->is_nan();
    } else {
	return $UNDEF;
    }
}

1;

__END__