Re: BigInt bug with non-integer accuracy/precision

Message-Id: <200709221133.35110@bloodgate.com>

p4raw-id: //depot/perl@31951

3 files changed, 158 insertions, 6 deletions

diff --git a/MANIFEST b/MANIFEST
index c0950df840..3a15d83d22 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2059,6 +2059,7 @@ lib/Math/BigInt/t/req_mbfi.t	test: require Math::BigFloat; ->binf();
 lib/Math/BigInt/t/req_mbfn.t	test: require Math::BigFloat; ->new();
 lib/Math/BigInt/t/req_mbfw.t	require Math::BigFloat; import ( with => );
 lib/Math/BigInt/t/require.t	Test if require Math::BigInt works
+lib/Math/BigInt/t/round.t	Test rounding with non-integer A and P
 lib/Math/BigInt/t/sub_ali.t	Tests for aliases in BigInt subclasses
 lib/Math/BigInt/t/sub_mbf.t	Empty subclass test of BigFloat
 lib/Math/BigInt/t/sub_mbi.t	Empty subclass test of BigInt
diff --git a/lib/Math/BigInt.pm b/lib/Math/BigInt.pm
index 84af8722a2..362769ffdf 100644
--- a/lib/Math/BigInt.pm
+++ b/lib/Math/BigInt.pm
@@ -291,11 +291,12 @@ sub accuracy
       if (!$a || $a <= 0)
         {
         require Carp;
-        Carp::croak ('Argument to accuracy must be greater than zero');
+	Carp::croak ('Argument to accuracy must be greater than zero');
         }
       if (int($a) != $a)
         {
-        require Carp; Carp::croak ('Argument to accuracy must be an integer');
+        require Carp;
+	Carp::croak ('Argument to accuracy must be an integer');
         }
       }
     if (ref($x))
@@ -449,6 +450,12 @@ sub _scale_a
   $scale = ${ $class . '::accuracy' } unless defined $scale;
   $mode = ${ $class . '::round_mode' } unless defined $mode;
 
+  if (defined $scale)
+    {
+    $scale = $scale->can('numify') ? $scale->numify() : "$scale" if ref($scale);
+    $scale = int($scale);
+    }
+
   ($scale,$mode);
   }
 
@@ -466,6 +473,12 @@ sub _scale_p
   $scale = ${ $class . '::precision' } unless defined $scale;
   $mode = ${ $class . '::round_mode' } unless defined $mode;
 
+  if (defined $scale)
+    {
+    $scale = $scale->can('numify') ? $scale->numify() : "$scale" if ref($scale);
+    $scale = int($scale);
+    }
+
   ($scale,$mode);
   }
 
@@ -907,6 +920,9 @@ sub _find_round_parameters
     require Carp; Carp::croak ("Unknown round mode '$r'");
     }
 
+  $a = int($a) if defined $a;
+  $p = int($p) if defined $p;
+
   ($self,$a,$p,$r);
   }
 
@@ -967,11 +983,11 @@ sub round
   # now round, by calling either fround or ffround:
   if (defined $a)
     {
-    $self->bround($a,$r) if !defined $self->{_a} || $self->{_a} >= $a;
+    $self->bround(int($a),$r) if !defined $self->{_a} || $self->{_a} >= $a;
     }
   else # both can't be undefined due to early out
     {
-    $self->bfround($p,$r) if !defined $self->{_p} || $self->{_p} <= $p;
+    $self->bfround(int($p),$r) if !defined $self->{_p} || $self->{_p} <= $p;
     }
   # bround() or bfround() already callled bnorm() if nec.
   $self;
@@ -3147,7 +3163,9 @@ Math::BigInt - Arbitrary size integer/float math package
   
   $x->round($A,$P,$mode);  # round to accuracy or precision using mode $mode
   $x->bround($n);	   # accuracy: preserve $n digits
-  $x->bfround($n);	   # round to $nth digit, no-op for BigInts
+  $x->bfround($n);	   # $n > 0: round $nth digits,
+			   # $n < 0: round to the $nth digit after the
+			   # dot, no-op for BigInts
 
   # The following do not modify their arguments in BigInt (are no-ops),
   # but do so in BigFloat:
@@ -3819,7 +3837,20 @@ C<$round_mode>.
 
 =head2 bfround()
 
-	$x->bfround($N);              # round to $Nth digit, no-op for BigInts
+	$x->bfround($N);
+
+If N is > 0, rounds to the Nth digit from the left. If N < 0, rounds to
+the Nth digit after the dot. Since BigInts are integers, the case N < 0
+is a no-op for them.
+
+Examples:
+
+	Input		N		Result
+	===================================================
+	123456.123456	3		123500
+	123456.123456	2		123450
+	123456.123456	-2		123456.12
+	123456.123456	-3		123456.123
 
 =head2 bfloor()
 
diff --git a/lib/Math/BigInt/t/round.t b/lib/Math/BigInt/t/round.t
new file mode 100644
index 0000000000..90c46758a7
--- /dev/null
+++ b/lib/Math/BigInt/t/round.t
@@ -0,0 +1,120 @@
+#!/usr/bin/perl -w
+
+# test rounding with non-integer A and P parameters
+
+use strict;
+use Test::More;
+
+BEGIN
+  {
+  $| = 1;
+  # to locate the testing files
+  my $location = $0; $location =~ s/round.t//i;
+  if ($ENV{PERL_CORE})
+    {
+    # testing with the core distribution
+    @INC = qw(../t/lib);
+    }
+  unshift @INC, qw(../lib);
+  if (-d 't')
+    {
+    chdir 't';
+    require File::Spec;
+    unshift @INC, File::Spec->catdir(File::Spec->updir, $location);
+    }
+  else
+    {
+    unshift @INC, $location;
+    }
+  print "# INC = @INC\n";
+
+  plan tests => 95;
+  } 
+
+use Math::BigFloat;
+
+my $cf = 'Math::BigFloat';
+my $ci = 'Math::BigInt';
+
+my $x = $cf->new('123456.123456');
+
+# unary ops with A
+_do_a($x, 'round', 3, '123000');
+_do_a($x, 'bfround', 3, '123500');
+_do_a($x, 'bfround', 2, '123460');
+_do_a($x, 'bfround', -2, '123456.12');
+_do_a($x, 'bfround', -3, '123456.123');
+
+_do_a($x, 'bround', 4, '123500');
+_do_a($x, 'bround', 3, '123000');
+_do_a($x, 'bround', 2, '120000');
+
+_do_a($x, 'bsqrt', 4, '351.4');
+_do_a($x, 'bsqrt', 3, '351');
+_do_a($x, 'bsqrt', 2, '350');
+
+# setting P
+_do_p($x, 'bsqrt', 2,  '350');
+_do_p($x, 'bsqrt', -2, '351.36');
+
+# binary ops
+_do_2_a($x, 'bdiv', 2, 6, '61728.1');
+_do_2_a($x, 'bdiv', 2, 4, '61730');
+_do_2_a($x, 'bdiv', 2, 3, '61700');
+
+_do_2_p($x, 'bdiv', 2, -6, '61728.061728');
+_do_2_p($x, 'bdiv', 2, -4, '61728.0617');
+_do_2_p($x, 'bdiv', 2, -3, '61728.062');
+
+# all tests done
+
+#############################################################################
+
+sub _do_a
+  { 
+  my ($x, $method, $A, $result) = @_;
+
+  is ($x->copy->$method($A), $result, "$method($A)");
+  is ($x->copy->$method($A.'.1'), $result, "$method(${A}.1)");
+  is ($x->copy->$method($A.'.5'), $result, "$method(${A}.5)");
+  is ($x->copy->$method($A.'.6'), $result, "$method(${A}.6)");
+  is ($x->copy->$method($A.'.9'), $result, "$method(${A}.9)");
+  }
+
+sub _do_p
+  { 
+  my ($x, $method, $P, $result) = @_;
+
+  is ($x->copy->$method(undef,$P), $result, "$method(undef,$P)");
+  is ($x->copy->$method(undef,$P.'.1'), $result, "$method(undef,${P}.1)");
+  is ($x->copy->$method(undef,$P.'.5'), $result, "$method(undef.${P}.5)");
+  is ($x->copy->$method(undef,$P.'.6'), $result, "$method(undef,${P}.6)");
+  is ($x->copy->$method(undef,$P.'.9'), $result, "$method(undef,${P}.9)");
+  }
+
+sub _do_2_a
+  { 
+  my ($x, $method, $y, $A, $result) = @_;
+
+  my $cy = $cf->new($y);
+
+  is ($x->copy->$method($cy,$A), $result, "$method($cy,$A)");
+  is ($x->copy->$method($cy,$A.'.1'), $result, "$method($cy,${A}.1)");
+  is ($x->copy->$method($cy,$A.'.5'), $result, "$method($cy,${A}.5)");
+  is ($x->copy->$method($cy,$A.'.6'), $result, "$method($cy,${A}.6)");
+  is ($x->copy->$method($cy,$A.'.9'), $result, "$method($cy,${A}.9)");
+  }
+
+sub _do_2_p
+  { 
+  my ($x, $method, $y, $P, $result) = @_;
+
+  my $cy = $cf->new($y);
+
+  is ($x->copy->$method($cy,undef,$P), $result, "$method(undef,$P)");
+  is ($x->copy->$method($cy,undef,$P.'.1'), $result, "$method($cy,undef,${P}.1)");
+  is ($x->copy->$method($cy,undef,$P.'.5'), $result, "$method($cy,undef.${P}.5)");
+  is ($x->copy->$method($cy,undef,$P.'.6'), $result, "$method($cy,undef,${P}.6)");
+  is ($x->copy->$method($cy,undef,$P.'.9'), $result, "$method($cy,undef,${P}.9)");
+  }
+