bigfltpm.inc

source of perl for linux application,

#include this file into another test for subclass testing...

ok ($class->config()->{lib},$CL);

use strict;

my $z;

while (<DATA>)
  {
  chomp;
  $_ =~ s/#.*$//;	# remove comments
  $_ =~ s/\s+$//;	# trailing spaces
  next if /^$/;		# skip empty lines & comments
  if (s/^&//)
    {
    $f = $_;
    }
  elsif (/^\$/)
    {
    $setup = $_; $setup =~ s/\$/\$${class}::/g;	# round_mode, div_scale
    #print "\$setup== $setup\n";
    }
  else
    {
    if (m|^(.*?):(/.+)$|)
      {
      $ans = $2;
      @args = split(/:/,$1,99);
      }
    else
      {
      @args = split(/:/,$_,99); $ans = pop(@args);
      }
    $try = "\$x = $class->new(\"$args[0]\");";
    if ($f eq "fnorm")
      {
        $try .= "\$x;";
      } elsif ($f eq "finf") {
        $try .= "\$x->finf('$args[1]');";
      } elsif ($f eq "is_inf") {
        $try .= "\$x->is_inf('$args[1]');"; 
      } elsif ($f eq "fone") {
        $try .= "\$x->bone('$args[1]');";
      } elsif ($f eq "fstr") {
        $try .= "\$x->accuracy($args[1]); \$x->precision($args[2]);";
        $try .= '$x->fstr();';
      } elsif ($f eq "parts") {
        # ->bstr() to see if an object is returned
        $try .= '($a,$b) = $x->parts(); $a = $a->bstr(); $b = $b->bstr();';
        $try .= '"$a $b";';
      } elsif ($f eq "exponent") {
        # ->bstr() to see if an object is returned
        $try .= '$x->exponent()->bstr();';
      } elsif ($f eq "mantissa") {
        # ->bstr() to see if an object is returned
        $try .= '$x->mantissa()->bstr();';
      } elsif ($f =~ /^(numify|length|as_number|as_hex|as_bin)$/) {
        $try .= "\$x->$f();";
      # some unary ops (test the fxxx form, since that is done by AUTOLOAD)
      } elsif ($f =~ /^f(nan|sstr|neg|floor|ceil|abs)$/) {
        $try .= "\$x->f$1();";
      # some is_xxx test function	
      } elsif ($f =~ /^is_(zero|one|negative|positive|odd|even|nan|int)$/) {
        $try .= "\$x->$f();";
      } elsif ($f eq "finc") {
        $try .= '++$x;';
      } elsif ($f eq "fdec") {
        $try .= '--$x;';
      }elsif ($f eq "fround") {
        $try .= "$setup; \$x->fround($args[1]);";
      } elsif ($f eq "ffround") {
        $try .= "$setup; \$x->ffround($args[1]);";
      } elsif ($f eq "fsqrt") {
        $try .= "$setup; \$x->fsqrt();";
      } elsif ($f eq "ffac") {
        $try .= "$setup; \$x->ffac();";
      } elsif ($f eq "flog") {
        if (defined $args[1] && $args[1] ne '')
          {
          $try .= "\$y = $class->new($args[1]);";
          $try .= "$setup; \$x->flog(\$y);";
          }
        else
          {
          $try .= "$setup; \$x->flog();";
          }
      }
    else
      {
      $try .= "\$y = $class->new(\"$args[1]\");";
      
      if ($f eq "bgcd")
        {
        if (defined $args[2])
          {
          $try .= " \$z = $class->new(\"$args[2]\"); ";
          }
        $try .= "$class\::bgcd(\$x, \$y";
        $try .= ", \$z" if (defined $args[2]);
        $try .= " );";
        }
      elsif ($f eq "blcm")
        {
        if (defined $args[2])
          {
          $try .= " \$z = $class->new(\"$args[2]\"); ";
          }
        $try .= "$class\::blcm(\$x, \$y";
        $try .= ", \$z" if (defined $args[2]);
        $try .= " );";
      } elsif ($f eq "fcmp") {
        $try .= '$x->fcmp($y);';
      } elsif ($f eq "facmp") {
        $try .= '$x->facmp($y);';
      } elsif ($f eq "fpow") {
        $try .= '$x ** $y;';
      } elsif ($f eq "bnok") {
        $try .= '$x->bnok($y);';
      } elsif ($f eq "froot") {
        $try .= "$setup; \$x->froot(\$y);";
      } elsif ($f eq "fadd") {
        $try .= '$x + $y;';
      } elsif ($f eq "fsub") {
        $try .= '$x - $y;';
      } elsif ($f eq "fmul") {
        $try .= '$x * $y;';
      } elsif ($f eq "fdiv") {
        $try .= "$setup; \$x / \$y;";
      } elsif ($f eq "fdiv-list") {
        $try .= "$setup; join(',',\$x->fdiv(\$y));";
      } elsif ($f eq "frsft") {
        $try .= '$x >> $y;';
      } elsif ($f eq "flsft") {
        $try .= '$x << $y;';
      } elsif ($f eq "fmod") {
        $try .= '$x % $y;';
      } else { warn "Unknown op '$f'"; }
    }
    # print "# Trying: '$try'\n";
    $ans1 = eval $try;
    print "# Error: $@\n" if $@;
    if ($ans =~ m|^/(.*)$|)
      {
      my $pat = $1;
      if ($ans1 =~ /$pat/)
        {
        ok (1,1);
        }
      else
        {
        print "# '$try' expected: /$pat/ got: '$ans1'\n" if !ok(1,0);
        }
      }
    else
      {
      if ($ans eq "")
        {
        ok_undef ($ans1);
        }
      else
        {
        print "# Tried: '$try'\n" if !ok ($ans1, $ans);
        if (ref($ans1) eq "$class")
	  {
	  # float numbers are normalized (for now), so mantissa shouldn't have
	  # trailing zeros
	  #print $ans1->_trailing_zeros(),"\n";
          print "# Has trailing zeros after '$try'\n"
	   if !ok ($CL->_zeros( $ans1->{_m}), 0);
	  }
        }
      } # end pattern or string
    }
  } # end while

# check whether $class->new( Math::BigInt->new()) destroys it 
# ($y == 12 in this case)
$x = Math::BigInt->new(1200); $y = $class->new($x);
ok ($y,1200); ok ($x,1200);

###############################################################################
# Really huge, big, ultra-mega-biggy-monster exponents
# Technically, the exponents should not be limited (they are BigInts), but
# practically there are a few places were they are limited to a Perl scalar.
# This is sometimes for speed, sometimes because otherwise the number wouldn't
# fit into your memory (just think of 1e123456789012345678901234567890 + 1!)
# anyway. We don't test everything here, but let's make sure it just basically
# works.

my $monster = '1e1234567890123456789012345678901234567890';

# new and exponent
ok ($class->new($monster)->bsstr(), 
		'1e+1234567890123456789012345678901234567890');
ok ($class->new($monster)->exponent(), 
		'1234567890123456789012345678901234567890');
# cmp
ok ($class->new($monster) > 0,1);

# sub/mul 
ok ($class->new($monster)->bsub( $monster),0);
ok ($class->new($monster)->bmul(2)->bsstr(),
                '2e+1234567890123456789012345678901234567890');

# mantissa
$monster = '1234567890123456789012345678901234567890e2';
ok ($class->new($monster)->mantissa(), 
		'123456789012345678901234567890123456789');

###############################################################################
# zero,inf,one,nan

$x = $class->new(2); $x->fzero(); ok_undef ($x->{_a}); ok_undef ($x->{_p});
$x = $class->new(2); $x->finf();  ok_undef ($x->{_a}); ok_undef ($x->{_p});
$x = $class->new(2); $x->fone();  ok_undef ($x->{_a}); ok_undef ($x->{_p});
$x = $class->new(2); $x->fnan();  ok_undef ($x->{_a}); ok_undef ($x->{_p});

###############################################################################
# bone/binf etc as plain calls (Lite failed them)

ok ($class->fzero(),0);
ok ($class->fone(),1);
ok ($class->fone('+'),1);
ok ($class->fone('-'),-1);
ok ($class->fnan(),'NaN');
ok ($class->finf(),'inf');
ok ($class->finf('+'),'inf');
ok ($class->finf('-'),'-inf');
ok ($class->finf('-inf'),'-inf');
        
$class->accuracy(undef); $class->precision(undef);	# reset

###############################################################################
# bug in bsstr()/numify() showed up in after-rounding in bdiv()

$x = $class->new('0.008'); $y = $class->new(2);
$x->bdiv(3,$y);
ok ($x,'0.0027');

###############################################################################
# fsqrt() with set global A/P or A/P enabled on $x, also a test whether fsqrt()
# correctly modifies $x


$x = $class->new(12); $class->precision(-2); $x->fsqrt(); ok ($x,'3.46');

$class->precision(undef);
$x = $class->new(12); $class->precision(0); $x->fsqrt(); ok ($x,'3');

$class->precision(-3); $x = $class->new(12); $x->fsqrt(); ok ($x,'3.464');

{
  no strict 'refs';
  # A and P set => NaN
  ${${class}.'::accuracy'} = 4; $x = $class->new(12);
  $x->fsqrt(3); ok ($x,'NaN');
  # supplied arg overrides set global
  $class->precision(undef); $x = $class->new(12); $x->fsqrt(3); ok ($x,'3.46');
  $class->accuracy(undef); $class->precision(undef); # reset for further tests
}

#############################################################################
# can we call objectify (broken until v1.52)

{
  no strict;
  $try = 
    '@args' . " = $class" . "::objectify(2,$class,4,5);".'join(" ",@args);';
  $ans = eval $try;
  ok ($ans,"$class 4 5");
}

#############################################################################
# is_one('-') (broken until v1.64)

ok ($class->new(-1)->is_one(),0);
ok ($class->new(-1)->is_one('-'),1);

#############################################################################
# bug 1/0.5 leaving 2e-0 instead of 2e0

ok ($class->new(1)->fdiv('0.5')->bsstr(),'2e+0');

###############################################################################
# [perl #30609] bug with $x -= $x not being 0, but 2*$x

$x = $class->new(3);  $x -= $x; ok ($x, 0);
$x = $class->new(-3); $x -= $x; ok ($x, 0);
$x = $class->new(3);  $x += $x; ok ($x, 6);
$x = $class->new(-3); $x += $x; ok ($x, -6);

$x = $class->new('NaN'); $x -= $x; ok ($x->is_nan(), 1);
$x = $class->new('inf'); $x -= $x; ok ($x->is_nan(), 1);
$x = $class->new('-inf'); $x -= $x; ok ($x->is_nan(), 1);

$x = $class->new('NaN'); $x += $x; ok ($x->is_nan(), 1);
$x = $class->new('inf'); $x += $x; ok ($x->is_inf(), 1);
$x = $class->new('-inf'); $x += $x; ok ($x->is_inf('-'), 1);

$x = $class->new('3.14');  $x -= $x; ok ($x, 0);
$x = $class->new('-3.14'); $x -= $x; ok ($x, 0);
$x = $class->new('3.14');  $x += $x; ok ($x, '6.28');
$x = $class->new('-3.14'); $x += $x; ok ($x, '-6.28');

$x = $class->new('3.14');  $x *= $x; ok ($x, '9.8596');
$x = $class->new('-3.14'); $x *= $x; ok ($x, '9.8596');
$x = $class->new('3.14');  $x /= $x; ok ($x, '1');
$x = $class->new('-3.14'); $x /= $x; ok ($x, '1');
$x = $class->new('3.14');  $x %= $x; ok ($x, '0');
$x = $class->new('-3.14'); $x %= $x; ok ($x, '0');

###############################################################################
# the following two were reported by "kenny" via hotmail.com:

#perl -MMath::BigFloat -wle 'print Math::BigFloat->new(0)->bpow(".1")'
#Use of uninitialized value in numeric le (<=) at BigFloat.pm line 1851.

$x = $class->new(0); $y = $class->new('0.1');
ok ($x ** $y, 0, 'no warnings and zero result');

#perl -MMath::BigFloat -lwe 'print Math::BigFloat->new(".222222222222222222222222222222222222222222")->bceil()'
#Use of uninitialized value in numeric le (<=) at BigFloat.pm line 1851.

$x = $class->new(".222222222222222222222222222222222222222222"); 
ok ($x->bceil(), 1, 'no warnings and one as result');

###############################################################################
# test **=, <<=, >>=

# ((2^148)-1)/17
$x = $class->new(2); $x **= 148; $x++; $x->bdiv(17, 60)->bfloor(); $x->accuracy(undef);
ok ($x,"20988936657440586486151264256610222593863921");
ok ($x->length(),length "20988936657440586486151264256610222593863921");

$x = $class->new('2');
my $y = $class->new('18');
ok ($x <<= $y, 2 << 18);
ok ($x, 2 << 18);
ok ($x >>= $y, 2);
ok ($x, 2);

$x = $class->new('2');
$y = $class->new('18.2');
$x <<= $y;		# 2 * (2 ** 18.2);

ok ($x->copy()->bfround(-9), '602248.763144685');
ok ($x >>= $y, 2);	# 2 * (2 ** 18.2) / (2 ** 18.2) => 2
ok ($x, 2);

1; # all done

###############################################################################
# Perl 5.005 does not like ok ($x,undef)

sub ok_undef
  {
  my $x = shift;

  ok (1,1) and return if !defined $x;
  ok ($x,'undef');
  }

__DATA__
&bgcd
inf:12:NaN
-inf:12:NaN
12:inf:NaN
12:-inf:NaN
inf:inf:NaN
inf:-inf:NaN
-inf:-inf:NaN
abc:abc:NaN
abc:+0:NaN
+0:abc:NaN
+0:+0:0
+0:+1:1
+1:+0:1
+1:+1:1
+2:+3:1
+3:+2:1
-3:+2:1
-3:-2:1
-144:-60:12
144:-60:12
144:60:12
100:625:25
4096:81:1
1034:804:2
27:90:56:1
27:90:54:9
&blcm
abc:abc:NaN
abc:+0:NaN
+0:abc:NaN
+0:+0:NaN
+1:+0:0
+0:+1:0
+27:+90:270
+1034:+804:415668
$div_scale = 40;
&bnok
+inf:10:inf
NaN:NaN:NaN
NaN:1:NaN
1:NaN:NaN
1:1:1
# k > n
1:2:0
2:3:0
# k < 0
1:-2:0
# 7 over 3 = 35
7:3:35
7:6:1
100:90:17310309456440
&flog
0::NaN
-1::NaN
-2::NaN
# base > 0, base != 1
2:-1:NaN
2:0:NaN
2:1:NaN
# log(1) is always 1, regardless of $base
1::0
1:1:0
1:2:0
2::0.6931471805599453094172321214581765680755
2.718281828::0.9999999998311266953289851340574956564911
$div_scale = 20;
2.718281828::0.99999999983112669533
$div_scale = 15;
123::4.81218435537242
10::2.30258509299405
1000::6.90775527898214
100::4.60517018598809
2::0.693147180559945
3.1415::1.14470039286086
12345::9.42100640177928
0.001::-6.90775527898214
# bug until v1.71:
10:10:1
100:100:1
# reset for further tests
$div_scale = 40;
1::0
&frsft
NaNfrsft:2:NaN
0:2:0
1:1:0.5
2:1:1
4:1:2
123:1:61.5
32:3:4
&flsft
NaNflsft:0:NaN
2:1:4
4:3:32
5:3:40
1:2:4
0:5:0
&fnorm
1:1
-0:0
fnormNaN:NaN
+inf:inf
-inf:-inf
123:123
-123.4567:-123.4567
# invalid inputs
1__2:NaN
1E1__2:NaN
11__2E2:NaN
.2E-3.:NaN
1e3e4:NaN
# strange, but valid
.2E2:20
1.E3:1000
# some inputs that result in zero
0e0:0
+0e0:0
+0e+0:0
-0e+0:0
0e-0:0
-0e-0:0
+0e-0:0
000:0
00e2:0
00e02:0
000e002:0
000e1230:0
00e-3:0
00e+3:0
00e-03:0
00e+03:0
-000:0
-00e2:0
-00e02:0
-000e002:0
-000e1230:0
-00e-3:0
-00e+3:0
-00e-03:0
-00e+03:0
&as_number
0:0
1:1
1.2:1
2.345:2
-2:-2
-123.456:-123
-200:-200
# test for bug in brsft() not handling cases that return 0
0.000641:0
0.0006412:0
0.00064123:0
0.000641234:0
0.0006412345:0
0.00064123456:0
0.000641234567:0
0.0006412345678:0
0.00064123456789:0
0.1:0
0.01:0
0.001:0
0.0001:0
0.00001:0
0.000001:0
0.0000001:0
0.00000001:0
0.000000001:0
0.0000000001:0
0.00000000001:0
0.12345:0
0.123456:0
0.1234567:0
0.12345678:0
0.123456789:0
&finf
1:+:inf
2:-:-inf
3:abc:inf
&as_hex
+inf:inf
-inf:-inf
hexNaN:NaN
0:0x0
5:0x5
-5:-0x5
&as_bin
+inf:inf
-inf:-inf
hexNaN:NaN
0:0b0
5:0b101
-5:-0b101
&numify