From: Tels <nospam-abuse@bloodgate.com>
Date: Sat, 17 Jul 2004 16:22:57 +0000 (+0200)
Subject: [perl #30609] [PATCH] BigInt v1.71 - first try
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=03874afe4126e47a07c482418278c13f14c14597;p=p5sagit%2Fp5-mst-13.2.git

[perl #30609] [PATCH] BigInt v1.71 - first try
Message-Id: <200407171622.58443@bloodgate.com>

p4raw-id: //depot/perl@23142
---

diff --git a/lib/Math/BigFloat.pm b/lib/Math/BigFloat.pm
index f7008aa..846f5f0 100644
--- a/lib/Math/BigFloat.pm
+++ b/lib/Math/BigFloat.pm
@@ -12,14 +12,14 @@ package Math::BigFloat;
 #   _a	: accuracy
 #   _p	: precision
 
-$VERSION = '1.44';
+$VERSION = '1.45';
 require 5.005;
 
 require Exporter;
 @ISA =       qw(Exporter Math::BigInt);
 
 use strict;
-# $_trap_inf and $_trap_nan are internal and should never be accessed from the outside
+# $_trap_inf/$_trap_nan are internal and should never be accessed from outside
 use vars qw/$AUTOLOAD $accuracy $precision $div_scale $round_mode $rnd_mode
 	    $upgrade $downgrade $_trap_nan $_trap_inf/;
 my $class = "Math::BigFloat";
@@ -626,30 +626,7 @@ sub badd
   $x->bnorm()->round($a,$p,$r,$y);
   }
 
-sub bsub 
-  {
-  # (BigFloat or num_str, BigFloat or num_str) return BigFloat
-  # subtract second arg from first, modify first
-
-  # set up parameters
-  my ($self,$x,$y,$a,$p,$r) = (ref($_[0]),@_);
-  # objectify is costly, so avoid it
-  if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
-    {
-    ($self,$x,$y,$a,$p,$r) = objectify(2,@_);
-    }
-
-  if ($y->is_zero())		# still round for not adding zero
-    {
-    return $x->round($a,$p,$r);
-    }
- 
-  # $x - $y = -$x + $y 
-  $y->{sign} =~ tr/+-/-+/;	# does nothing for NaN
-  $x->badd($y,$a,$p,$r);	# badd does not leave internal zeros
-  $y->{sign} =~ tr/+-/-+/;	# refix $y (does nothing for NaN)
-  $x;				# already rounded by badd()
-  }
+# sub bsub is inherited from Math::BigInt!
 
 sub binc
   {
@@ -1293,39 +1270,52 @@ sub bdiv
     # enough...
     $scale = abs($params[0] || $params[1]) + 4;	# take whatever is defined
     }
+
+  my $rem; $rem = $self->bzero() if wantarray;
+
+  $y = $self->new($y) unless $y->isa('Math::BigFloat');
+
   my $lx = $MBI->_len($x->{_m}); my $ly = $MBI->_len($y->{_m});
   $scale = $lx if $lx > $scale;
   $scale = $ly if $ly > $scale;
   my $diff = $ly - $lx;
   $scale += $diff if $diff > 0;		# if lx << ly, but not if ly << lx!
-    
-  # make copy of $x in case of list context for later reminder calculation
-  my $rem;
-  if (wantarray && !$y->is_one())
+  
+  # cases like $x /= $x (but not $x /= $y!) were wrong due to modifying $x
+  # twice below)
+  if (overload::StrVal($x) eq overload::StrVal($y)) 
     {
-    $rem = $x->copy();
+    $x->bone();				# x/x => 1, rem 0
     }
-
-  $x->{sign} = $x->{sign} ne $y->sign() ? '-' : '+'; 
-
-  # check for / +-1 ( +/- 1E0)
-  if (!$y->is_one())
+  else
     {
-    # promote BigInts and it's subclasses (except when already a BigFloat)
-    $y = $self->new($y) unless $y->isa('Math::BigFloat'); 
+ 
+    # make copy of $x in case of list context for later reminder calculation
+    if (wantarray && !$y->is_one())
+      {
+      $rem = $x->copy();
+      }
 
-    # calculate the result to $scale digits and then round it
-    # a * 10 ** b / c * 10 ** d => a/c * 10 ** (b-d)
-    $MBI->_lsft($x->{_m},$MBI->_new($scale),10);
-    $MBI->_div ($x->{_m},$y->{_m} );	# a/c
+    $x->{sign} = $x->{sign} ne $y->sign() ? '-' : '+'; 
 
-    ($x->{_e},$x->{_es}) = 
-     _e_sub($x->{_e}, $y->{_e}, $x->{_es}, $y->{_es});
-    # correct for 10**scale
-    ($x->{_e},$x->{_es}) = 
-      _e_sub($x->{_e}, $MBI->_new($scale), $x->{_es}, '+');
-    $x->bnorm();		# remove trailing 0's
-    }
+    # check for / +-1 ( +/- 1E0)
+    if (!$y->is_one())
+      {
+      # promote BigInts and it's subclasses (except when already a BigFloat)
+      $y = $self->new($y) unless $y->isa('Math::BigFloat'); 
+
+      # calculate the result to $scale digits and then round it
+      # a * 10 ** b / c * 10 ** d => a/c * 10 ** (b-d)
+      $MBI->_lsft($x->{_m},$MBI->_new($scale),10);
+      $MBI->_div ($x->{_m},$y->{_m});	# a/c
+
+      # correct exponent of $x
+      ($x->{_e},$x->{_es}) = _e_sub($x->{_e}, $y->{_e}, $x->{_es}, $y->{_es});
+      # correct for 10**scale
+      ($x->{_e},$x->{_es}) = _e_sub($x->{_e}, $MBI->_new($scale), $x->{_es}, '+');
+      $x->bnorm();		# remove trailing 0's
+      }
+    } # ende else $x != $y
 
   # shortcut to not run through _find_round_parameters again
   if (defined $params[0])
@@ -1343,17 +1333,13 @@ sub bdiv
     # clear a/p after round, since user did not request it
     delete $x->{_a}; delete $x->{_p};
     }
-  
+
   if (wantarray)
     {
     if (!$y->is_one())
       {
       $rem->bmod($y,@params);			# copy already done
       }
-    else
-      {
-      $rem = $self->bzero();
-      }
     if ($fallback)
       {
       # clear a/p after round, since user did not request it
diff --git a/lib/Math/BigInt.pm b/lib/Math/BigInt.pm
index 220920e..af361b4 100644
--- a/lib/Math/BigInt.pm
+++ b/lib/Math/BigInt.pm
@@ -18,7 +18,7 @@ package Math::BigInt;
 my $class = "Math::BigInt";
 require 5.005;
 
-$VERSION = '1.70_01';
+$VERSION = '1.71';
 use Exporter;
 @ISA =       qw( Exporter );
 @EXPORT_OK = qw( objectify bgcd blcm); 
@@ -1140,6 +1140,13 @@ sub bsub
     return $x;
     }
 
+  if (overload::StrVal($x) eq overload::StrVal($y))
+    {
+    # if we get the same variable twice, the result must be zero (the code
+    # below fails in that case)
+    return $x->bzero(@r) if $x->{sign} =~ /^[+-]$/;
+    return $x->bnan();          # NaN, -inf, +inf
+    }
   $y->{sign} =~ tr/+\-/-+/; 	# does nothing for NaN
   $x->badd($y,@r); 		# badd does not leave internal zeros
   $y->{sign} =~ tr/+\-/-+/; 	# refix $y (does nothing for NaN)
diff --git a/lib/Math/BigInt/Calc.pm b/lib/Math/BigInt/Calc.pm
index f2f0c87..c90d61b 100644
--- a/lib/Math/BigInt/Calc.pm
+++ b/lib/Math/BigInt/Calc.pm
@@ -6,7 +6,7 @@ use strict;
 
 use vars qw/$VERSION/;
 
-$VERSION = '0.40';
+$VERSION = '0.41';
 
 # Package to store unsigned big integers in decimal and do math with them
 
@@ -97,6 +97,21 @@ sub _base_len
   return ($BASE_LEN, $AND_BITS, $XOR_BITS, $OR_BITS, $BASE_LEN_SMALL, $MAX_VAL);
   }
 
+sub _new
+  {
+  # (ref to string) return ref to num_array
+  # Convert a number from string format (without sign) to internal base
+  # 1ex format. Assumes normalized value as input.
+  my $il = length($_[1])-1;
+
+  # < BASE_LEN due len-1 above
+  return [ int($_[1]) ] if $il < $BASE_LEN;	# shortcut for short numbers
+
+  # this leaves '00000' instead of int 0 and will be corrected after any op
+  [ reverse(unpack("a" . ($il % $BASE_LEN+1) 
+    . ("a$BASE_LEN" x ($il / $BASE_LEN)), $_[1])) ];
+  }                                                                             
+
 BEGIN
   {
   # from Daniel Pfeiffer: determine largest group of digits that is precisely
@@ -123,28 +138,7 @@ BEGIN
 
   use integer;
 
-  ############################################################################
-  # the next block is no longer important
-
-  ## this below detects 15 on a 64 bit system, because after that it becomes
-  ## 1e16  and not 1000000 :/ I can make it detect 18, but then I get a lot of
-  ## test failures. Ugh! (Tomake detect 18: uncomment lines marked with *)
-
-  #my $bi = 5;			# approx. 16 bit
-  #$num = int('9' x $bi);
-  ## $num = 99999; # *
-  ## while ( ($num+$num+1) eq '1' . '9' x $bi)	# *
-  #while ( int($num+$num+1) eq '1' . '9' x $bi)
-  #  {
-  #  $bi++; $num = int('9' x $bi);
-  #  # $bi++; $num *= 10; $num += 9;	# *
-  #  }
-  #$bi--;				# back off one step
-  # by setting them equal, we ignore the findings and use the default
-  # one-size-fits-all approach from former versions
-  my $bi = $e;				# XXX, this should work always
-
-  __PACKAGE__->_base_len($e,$bi);	# set and store
+  __PACKAGE__->_base_len($e);	# set and store
 
   # find out how many bits _and, _or and _xor can take (old default = 16)
   # I don't think anybody has yet 128 bit scalars, so let's play safe.
@@ -179,32 +173,13 @@ BEGIN
     } while ($OR_BITS < $max && $x == $z && $y == $x);
   $OR_BITS --;						# retreat one step
   
-  }
-
-###############################################################################
-
-sub _new
-  {
-  # (ref to string) return ref to num_array
-  # Convert a number from string format (without sign) to internal base
-  # 1ex format. Assumes normalized value as input.
-  my $il = length($_[1])-1;
-
-  # < BASE_LEN due len-1 above
-  return [ int($_[1]) ] if $il < $BASE_LEN;	# shortcut for short numbers
-
-  # this leaves '00000' instead of int 0 and will be corrected after any op
-  [ reverse(unpack("a" . ($il % $BASE_LEN+1) 
-    . ("a$BASE_LEN" x ($il / $BASE_LEN)), $_[1])) ];
-  }                                                                             
-  
-BEGIN
-  {
   $AND_MASK = __PACKAGE__->_new( ( 2 ** $AND_BITS ));
   $XOR_MASK = __PACKAGE__->_new( ( 2 ** $XOR_BITS ));
   $OR_MASK = __PACKAGE__->_new( ( 2 ** $OR_BITS ));
   }
 
+###############################################################################
+
 sub _zero
   {
   # create a zero
@@ -968,7 +943,7 @@ sub _digit
   
   my $elem = int($n / $BASE_LEN);	# which array element
   my $digit = $n % $BASE_LEN;		# which digit in this element
-  $elem = '0000'.@$x[$elem];		# get element padded with 0's
+  $elem = '0000000'.@$x[$elem];		# get element padded with 0's
   substr($elem,-$digit-1,1);
   }
 
@@ -1761,11 +1736,7 @@ sub _as_hex
   my ($c,$x) = @_;
 
   # fit's into one element (handle also 0x0 case)
-  if (@$x == 1)
-    {
-    my $t = sprintf("0x%x",$x->[0]);
-    return $t;
-    }
+  return sprintf("0x%x",$x->[0]) if @$x == 1;
 
   my $x1 = _copy($c,$x);
 
@@ -1779,7 +1750,6 @@ sub _as_hex
     {
     $x10000 = [ 0x1000 ]; $h = 'h3';
     }
-  # while (! _is_zero($c,$x1))
   while (@$x1 != 1 || $x1->[0] != 0)		# _is_zero()
     {
     ($x1, $xr) = _div($c,$x1,$x10000);
@@ -1787,8 +1757,7 @@ sub _as_hex
     }
   $es = reverse $es;
   $es =~ s/^[0]+//;   # strip leading zeros
-  $es = '0x' . $es;
-  $es;
+  '0x' . $es;					# return result prepended with 0x
   }
 
 sub _as_bin
@@ -1819,7 +1788,6 @@ sub _as_bin
     {
     $x10000 = [ 0x1000 ]; $b = 'b12';
     }
-  # while (! _is_zero($c,$x1))
   while (!(@$x1 == 1 && $x1->[0] == 0))		# _is_zero()
     {
     ($x1, $xr) = _div($c,$x1,$x10000);
@@ -1828,8 +1796,7 @@ sub _as_bin
     }
   $es = reverse $es;
   $es =~ s/^[0]+//;   # strip leading zeros
-  $es = '0b' . $es;
-  $es;
+  '0b' . $es;					# return result prepended with 0b
   }
 
 sub _from_hex
@@ -1837,19 +1804,26 @@ sub _from_hex
   # convert a hex number to decimal (ref to string, return ref to array)
   my ($c,$hs) = @_;
 
+  my $m = [ 0x10000000 ];			# 28 bit at a time (<32 bit!)
+  my $d = 7;					# 7 digits at a time
+  if ($] <= 5.006)
+    {
+    # for older Perls, play safe
+    $m = [ 0x10000 ];				# 16 bit at a time (<32 bit!)
+    $d = 4;					# 4 digits at a time
+    }
+
   my $mul = _one();
-  my $m = [ 0x10000 ];				# 16 bit at a time
   my $x = _zero();
 
-  my $len = length($hs)-2;
-  $len = int($len/4);				# 4-digit parts, w/o '0x'
-  my $val; my $i = -4;
+  my $len = int( (length($hs)-2)/$d );		# $d digit parts, w/o the '0x'
+  my $val; my $i = -$d;
   while ($len >= 0)
     {
-    $val = substr($hs,$i,4);
+    $val = substr($hs,$i,$d);			# get hex digits
     $val =~ s/^[+-]?0x// if $len == 0;		# for last part only because
     $val = hex($val);				# hex does not like wrong chars
-    $i -= 4; $len --;
+    $i -= $d; $len --;
     _add ($c, $x, _mul ($c, [ $val ], $mul ) ) if $val != 0;
     _mul ($c, $mul, $m ) if $len >= 0; 		# skip last mul
     }
@@ -1868,9 +1842,9 @@ sub _from_bin
   $hs =~ s/^[+-]?0b//;					# remove sign and 0b
   my $l = length($hs);					# bits
   $hs = '0' x (8-($l % 8)) . $hs if ($l % 8) != 0;	# padd left side w/ 0
-  my $h = unpack('H*', pack ('B*', $hs));		# repack as hex
+  my $h = '0x' . unpack('H*', pack ('B*', $hs));	# repack as hex
   
-  $c->_from_hex('0x'.$h);
+  $c->_from_hex($h);
   }
 
 ##############################################################################
@@ -1903,8 +1877,7 @@ sub _modinv
   # if the gcd is not 1, then return NaN
   return (undef,undef) unless _is_one($c,$a);
  
-  $sign = $sign == 1 ? '+' : '-';
-  ($u1,$sign);
+  ($u1, $sign == 1 ? '+' : '-');
   }
 
 sub _modpow
diff --git a/lib/Math/BigInt/t/bare_mbf.t b/lib/Math/BigInt/t/bare_mbf.t
index cbca372..336ca01 100644
--- a/lib/Math/BigInt/t/bare_mbf.t
+++ b/lib/Math/BigInt/t/bare_mbf.t
@@ -27,7 +27,7 @@ BEGIN
     }
   print "# INC = @INC\n";
 
-  plan tests => 1815;
+  plan tests => 1835;
   }
 
 use Math::BigFloat lib => 'BareCalc';
diff --git a/lib/Math/BigInt/t/bare_mbi.t b/lib/Math/BigInt/t/bare_mbi.t
index 6514e1e..4f8b0ae 100644
--- a/lib/Math/BigInt/t/bare_mbi.t
+++ b/lib/Math/BigInt/t/bare_mbi.t
@@ -26,7 +26,7 @@ BEGIN
     }
   print "# INC = @INC\n";
 
-  plan tests => 2832;
+  plan tests => 2848;
   }
 
 use Math::BigInt lib => 'BareCalc';
diff --git a/lib/Math/BigInt/t/bigfltpm.inc b/lib/Math/BigInt/t/bigfltpm.inc
index 5e1c19f..4e38e5b 100644
--- a/lib/Math/BigInt/t/bigfltpm.inc
+++ b/lib/Math/BigInt/t/bigfltpm.inc
@@ -257,6 +257,34 @@ ok ($class->new(-1)->is_one('-'),1);
 
 ok ($class->new(1)->fdiv('0.5')->bsstr(),'2e+0');
 
+###############################################################################
+# [perl #30609] bug with $x -= $x not beeing 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');
+
 1; # all done
 
 ###############################################################################
diff --git a/lib/Math/BigInt/t/bigfltpm.t b/lib/Math/BigInt/t/bigfltpm.t
index 9e50f5e..b81114c 100755
--- a/lib/Math/BigInt/t/bigfltpm.t
+++ b/lib/Math/BigInt/t/bigfltpm.t
@@ -26,7 +26,7 @@ BEGIN
     }
   print "# INC = @INC\n";
 
-  plan tests => 1815
+  plan tests => 1835
 	+ 2;		# own tests
   }
 
diff --git a/lib/Math/BigInt/t/bigintpm.inc b/lib/Math/BigInt/t/bigintpm.inc
index cdefea6..77b55b9 100644
--- a/lib/Math/BigInt/t/bigintpm.inc
+++ b/lib/Math/BigInt/t/bigintpm.inc
@@ -624,6 +624,28 @@ ok ($class->new(1)->is_one(),1);
 ok ($class->new(-1)->is_one(),0);
 
 ###############################################################################
+# [perl #30609] bug with $x -= $x not beeing 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('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);  $x += $x; ok ($x, 6);
+$x = $class->new(-3); $x += $x; ok ($x, -6);
+
+$x = $class->new(3);  $x *= $x; ok ($x, 9);
+$x = $class->new(-3); $x *= $x; ok ($x, 9);
+$x = $class->new(3);  $x /= $x; ok ($x, 1);
+$x = $class->new(-3); $x /= $x; ok ($x, 1);
+$x = $class->new(3);  $x %= $x; ok ($x, 0);
+$x = $class->new(-3); $x %= $x; ok ($x, 0);
+
+###############################################################################
 # all tests done
 
 1;
diff --git a/lib/Math/BigInt/t/bigintpm.t b/lib/Math/BigInt/t/bigintpm.t
index 50fca1d..ba0b314 100755
--- a/lib/Math/BigInt/t/bigintpm.t
+++ b/lib/Math/BigInt/t/bigintpm.t
@@ -10,7 +10,7 @@ BEGIN
   my $location = $0; $location =~ s/bigintpm.t//;
   unshift @INC, $location; # to locate the testing files
   chdir 't' if -d 't';
-  plan tests => 2832;
+  plan tests => 2848;
   }
 
 use Math::BigInt;
diff --git a/lib/Math/BigInt/t/sub_mbf.t b/lib/Math/BigInt/t/sub_mbf.t
index 8550a97..e72506c 100755
--- a/lib/Math/BigInt/t/sub_mbf.t
+++ b/lib/Math/BigInt/t/sub_mbf.t
@@ -26,7 +26,7 @@ BEGIN
     }
   print "# INC = @INC\n"; 
   
-  plan tests => 1815
+  plan tests => 1835
     + 6;	# + our own tests
   }
 
diff --git a/lib/Math/BigInt/t/sub_mbi.t b/lib/Math/BigInt/t/sub_mbi.t
index 3e831c5..69abaae 100755
--- a/lib/Math/BigInt/t/sub_mbi.t
+++ b/lib/Math/BigInt/t/sub_mbi.t
@@ -26,7 +26,7 @@ BEGIN
     }
   print "# INC = @INC\n";
 
-  plan tests => 2832
+  plan tests => 2848
     + 5;	# +5 own tests
   }
 
diff --git a/lib/Math/BigInt/t/with_sub.t b/lib/Math/BigInt/t/with_sub.t
index 3d48030..be6efa0 100644
--- a/lib/Math/BigInt/t/with_sub.t
+++ b/lib/Math/BigInt/t/with_sub.t
@@ -28,7 +28,7 @@ BEGIN
     }
   print "# INC = @INC\n";
 
-  plan tests => 1815
+  plan tests => 1835
 	+ 1;
   }