lib/bigfloat.pl

   1 warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n";
   2
   3 package bigfloat;
   4 require "bigint.pl";
   5 #
   6 # This library is no longer being maintained, and is included for backward
   7 # compatibility with Perl 4 programs which may require it.
   8 # This legacy library is deprecated and will be removed in a future
   9 # release of perl.
  10 #
  11 # In particular, this should not be used as an example of modern Perl
  12 # programming techniques.
  13 #
  14 # Suggested alternative: Math::BigFloat
  15
  16 # Arbitrary length float math package
  17 #
  18 # by Mark Biggar
  19 #
  20 # number format
  21 #   canonical strings have the form /[+-]\d+E[+-]\d+/
  22 #   Input values can have embedded whitespace
  23 # Error returns
  24 #   'NaN'           An input parameter was "Not a Number" or
  25 #                       divide by zero or sqrt of negative number
  26 # Division is computed to
  27 #   max($div_scale,length(dividend)+length(divisor))
  28 #   digits by default.
  29 # Also used for default sqrt scale
  30
  31 $div_scale = 40;
  32
  33 # Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'.
  34
  35 $rnd_mode = 'even';
  36
  37 #   bigfloat routines
  38 #
  39 #   fadd(NSTR, NSTR) return NSTR            addition
  40 #   fsub(NSTR, NSTR) return NSTR            subtraction
  41 #   fmul(NSTR, NSTR) return NSTR            multiplication
  42 #   fdiv(NSTR, NSTR[,SCALE]) returns NSTR   division to SCALE places
  43 #   fneg(NSTR) return NSTR                  negation
  44 #   fabs(NSTR) return NSTR                  absolute value
  45 #   fcmp(NSTR,NSTR) return CODE             compare undef,<0,=0,>0
  46 #   fround(NSTR, SCALE) return NSTR         round to SCALE digits
  47 #   ffround(NSTR, SCALE) return NSTR        round at SCALEth place
  48 #   fnorm(NSTR) return (NSTR)               normalize
  49 #   fsqrt(NSTR[, SCALE]) return NSTR        sqrt to SCALE places
  50 \f
  51 # Convert a number to canonical string form.
  52 #   Takes something that looks like a number and converts it to
  53 #   the form /^[+-]\d+E[+-]\d+$/.
  54 sub main'fnorm { #(string) return fnum_str
  55     local($_) = @_;
  56     s/\s+//g;                               # strip white space
  57     if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/
  58           && ($2 ne '' || defined($4))) {
  59         my $x = defined($4) ? $4 : '';
  60         &norm(($1 ? "$1$2$x" : "+$2$x"), (($x ne '') ? $6-length($x) : $6));
  61     } else {
  62         'NaN';
  63     }
  64 }
  65
  66 # normalize number -- for internal use
  67 sub norm { #(mantissa, exponent) return fnum_str
  68     local($_, $exp) = @_;
  69     if ($_ eq 'NaN') {
  70         'NaN';
  71     } else {
  72         s/^([+-])0+/$1/;                        # strip leading zeros
  73         if (length($_) == 1) {
  74             '+0E+0';
  75         } else {
  76             $exp += length($1) if (s/(0+)$//);  # strip trailing zeros
  77             sprintf("%sE%+ld", $_, $exp);
  78         }
  79     }
  80 }
  81
  82 # negation
  83 sub main'fneg { #(fnum_str) return fnum_str
  84     local($_) = &'fnorm($_[0]);
  85     vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign
  86     if ( ord("\t") == 9 ) { # ascii
  87         s/^H/N/;
  88     }
  89     else { # ebcdic character set
  90         s/\373/N/;
  91     }
  92     $_;
  93 }
  94
  95 # absolute value
  96 sub main'fabs { #(fnum_str) return fnum_str
  97     local($_) = &'fnorm($_[0]);
  98     s/^-/+/;                                   # mash sign
  99     $_;
 100 }
 101
 102 # multiplication
 103 sub main'fmul { #(fnum_str, fnum_str) return fnum_str
 104     local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
 105     if ($x eq 'NaN' || $y eq 'NaN') {
 106         'NaN';
 107     } else {
 108         local($xm,$xe) = split('E',$x);
 109         local($ym,$ye) = split('E',$y);
 110         &norm(&'bmul($xm,$ym),$xe+$ye);
 111     }
 112 }
 113 \f
 114 # addition
 115 sub main'fadd { #(fnum_str, fnum_str) return fnum_str
 116     local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
 117     if ($x eq 'NaN' || $y eq 'NaN') {
 118         'NaN';
 119     } else {
 120         local($xm,$xe) = split('E',$x);
 121         local($ym,$ye) = split('E',$y);
 122         ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye);
 123         &norm(&'badd($ym,$xm.('0' x ($xe-$ye))),$ye);
 124     }
 125 }
 126
 127 # subtraction
 128 sub main'fsub { #(fnum_str, fnum_str) return fnum_str
 129     &'fadd($_[0],&'fneg($_[1]));
 130 }
 131
 132 # division
 133 #   args are dividend, divisor, scale (optional)
 134 #   result has at most max(scale, length(dividend), length(divisor)) digits
 135 sub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str
 136 {
 137     local($x,$y,$scale) = (&'fnorm($_[0]),&'fnorm($_[1]),$_[2]);
 138     if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') {
 139         'NaN';
 140     } else {
 141         local($xm,$xe) = split('E',$x);
 142         local($ym,$ye) = split('E',$y);
 143         $scale = $div_scale if (!$scale);
 144         $scale = length($xm)-1 if (length($xm)-1 > $scale);
 145         $scale = length($ym)-1 if (length($ym)-1 > $scale);
 146         $scale = $scale + length($ym) - length($xm);
 147         &norm(&round(&'bdiv($xm.('0' x $scale),$ym),&'babs($ym)),
 148             $xe-$ye-$scale);
 149     }
 150 }
 151 \f
 152 # round int $q based on fraction $r/$base using $rnd_mode
 153 sub round { #(int_str, int_str, int_str) return int_str
 154     local($q,$r,$base) = @_;
 155     if ($q eq 'NaN' || $r eq 'NaN') {
 156         'NaN';
 157     } elsif ($rnd_mode eq 'trunc') {
 158         $q;                         # just truncate
 159     } else {
 160         local($cmp) = &'bcmp(&'bmul($r,'+2'),$base);
 161         if ( $cmp < 0 ||
 162                  ($cmp == 0 &&
 163                   ( $rnd_mode eq 'zero'                             ||
 164                    ($rnd_mode eq '-inf' && (substr($q,0,1) eq '+')) ||
 165                    ($rnd_mode eq '+inf' && (substr($q,0,1) eq '-')) ||
 166                    ($rnd_mode eq 'even' && $q =~ /[24680]$/)        ||
 167                    ($rnd_mode eq 'odd'  && $q =~ /[13579]$/)        )) ) {
 168             $q;                     # round down
 169         } else {
 170             &'badd($q, ((substr($q,0,1) eq '-') ? '-1' : '+1'));
 171                                     # round up
 172         }
 173     }
 174 }
 175
 176 # round the mantissa of $x to $scale digits
 177 sub main'fround { #(fnum_str, scale) return fnum_str
 178     local($x,$scale) = (&'fnorm($_[0]),$_[1]);
 179     if ($x eq 'NaN' || $scale <= 0) {
 180         $x;
 181     } else {
 182         local($xm,$xe) = split('E',$x);
 183         if (length($xm)-1 <= $scale) {
 184             $x;
 185         } else {
 186             &norm(&round(substr($xm,0,$scale+1),
 187                          "+0".substr($xm,$scale+1,1),"+10"),
 188                   $xe+length($xm)-$scale-1);
 189         }
 190     }
 191 }
 192 \f
 193 # round $x at the 10 to the $scale digit place
 194 sub main'ffround { #(fnum_str, scale) return fnum_str
 195     local($x,$scale) = (&'fnorm($_[0]),$_[1]);
 196     if ($x eq 'NaN') {
 197         'NaN';
 198     } else {
 199         local($xm,$xe) = split('E',$x);
 200         if ($xe >= $scale) {
 201             $x;
 202         } else {
 203             $xe = length($xm)+$xe-$scale;
 204             if ($xe < 1) {
 205                 '+0E+0';
 206             } elsif ($xe == 1) {
 207                 # The first substr preserves the sign, which means that
 208                 # we'll pass a non-normalized "-0" to &round when rounding
 209                 # -0.006 (for example), purely so that &round won't lose
 210                 # the sign.
 211                 &norm(&round(substr($xm,0,1).'0',
 212                       "+0".substr($xm,1,1),"+10"), $scale);
 213             } else {
 214                 &norm(&round(substr($xm,0,$xe),
 215                       "+0".substr($xm,$xe,1),"+10"), $scale);
 216             }
 217         }
 218     }
 219 }
 220
 221 # compare 2 values returns one of undef, <0, =0, >0
 222 #   returns undef if either or both input value are not numbers
 223 sub main'fcmp #(fnum_str, fnum_str) return cond_code
 224 {
 225     local($x, $y) = (&'fnorm($_[0]),&'fnorm($_[1]));
 226     if ($x eq "NaN" || $y eq "NaN") {
 227         undef;
 228     } else {
 229         ord($y) <=> ord($x)
 230         ||
 231         (  local($xm,$xe,$ym,$ye) = split('E', $x."E$y"),
 232              (($xe <=> $ye) * (substr($x,0,1).'1')
 233              || &bigint'cmp($xm,$ym))
 234         );
 235     }
 236 }
 237 \f
 238 # square root by Newtons method.
 239 sub main'fsqrt { #(fnum_str[, scale]) return fnum_str
 240     local($x, $scale) = (&'fnorm($_[0]), $_[1]);
 241     if ($x eq 'NaN' || $x =~ /^-/) {
 242         'NaN';
 243     } elsif ($x eq '+0E+0') {
 244         '+0E+0';
 245     } else {
 246         local($xm, $xe) = split('E',$x);
 247         $scale = $div_scale if (!$scale);
 248         $scale = length($xm)-1 if ($scale < length($xm)-1);
 249         local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2));
 250         while ($gs < 2*$scale) {
 251             $guess = &'fmul(&'fadd($guess,&'fdiv($x,$guess,$gs*2)),".5");
 252             $gs *= 2;
 253         }
 254         &'fround($guess, $scale);
 255     }
 256 }
 257
 258 1;