| Commit | Line | Data |
|---|
| 61f5c3f5 |
1 | # test rounding, accuracy, precicion and fallback, round_mode and mixing |
| 2 | # of classes |
| 3 | |
| 4 | # Make sure you always quote any bare floating-point values, lest 123.46 will |
| 5 | # be stringified to 123.4599999999 due to limited float prevision. |
| 6 | |
| 7 | my ($x,$y,$z,$u,$rc); |
| 8 | |
| 9 | ############################################################################### |
| 10 | # test defaults and set/get |
| 11 | |
| 12 | ok_undef (${"$mbi\::accuracy"}); |
| 13 | ok_undef (${"$mbi\::precision"}); |
| 14 | ok_undef ($mbi->accuracy()); |
| 15 | ok_undef ($mbi->precision()); |
| 16 | ok (${"$mbi\::div_scale"},40); |
| 17 | ok (${"$mbi\::round_mode"},'even'); |
| 18 | ok ($mbi->round_mode(),'even'); |
| 19 | |
| 20 | ok_undef (${"$mbf\::accuracy"}); |
| 21 | ok_undef (${"$mbf\::precision"}); |
| 22 | ok_undef ($mbf->precision()); |
| 23 | ok_undef ($mbf->precision()); |
| 24 | ok (${"$mbf\::div_scale"},40); |
| 25 | ok (${"$mbf\::round_mode"},'even'); |
| 26 | ok ($mbf->round_mode(),'even'); |
| 27 | |
| 28 | # accessors |
| 29 | foreach my $class ($mbi,$mbf) |
| 30 | { |
| 31 | ok_undef ($class->accuracy()); |
| 32 | ok_undef ($class->precision()); |
| 33 | ok ($class->round_mode(),'even'); |
| 34 | ok ($class->div_scale(),40); |
| 35 | |
| 36 | ok ($class->div_scale(20),20); |
| 37 | $class->div_scale(40); ok ($class->div_scale(),40); |
| 38 | |
| 39 | ok ($class->round_mode('odd'),'odd'); |
| 40 | $class->round_mode('even'); ok ($class->round_mode(),'even'); |
| 41 | |
| 42 | ok ($class->accuracy(2),2); |
| 43 | $class->accuracy(3); ok ($class->accuracy(),3); |
| 44 | ok_undef ($class->accuracy(undef)); |
| 45 | |
| 46 | ok ($class->precision(2),2); |
| 47 | ok ($class->precision(-2),-2); |
| 48 | $class->precision(3); ok ($class->precision(),3); |
| 49 | ok_undef ($class->precision(undef)); |
| 50 | } |
| 51 | |
| 52 | # accuracy |
| 53 | foreach (qw/5 42 -1 0/) |
| 54 | { |
| 55 | ok (${"$mbf\::accuracy"} = $_,$_); |
| 56 | ok (${"$mbi\::accuracy"} = $_,$_); |
| 57 | } |
| 58 | ok_undef (${"$mbf\::accuracy"} = undef); |
| 59 | ok_undef (${"$mbi\::accuracy"} = undef); |
| 60 | |
| 61 | # precision |
| 62 | foreach (qw/5 42 -1 0/) |
| 63 | { |
| 64 | ok (${"$mbf\::precision"} = $_,$_); |
| 65 | ok (${"$mbi\::precision"} = $_,$_); |
| 66 | } |
| 67 | ok_undef (${"$mbf\::precision"} = undef); |
| 68 | ok_undef (${"$mbi\::precision"} = undef); |
| 69 | |
| 70 | # fallback |
| 71 | foreach (qw/5 42 1/) |
| 72 | { |
| 73 | ok (${"$mbf\::div_scale"} = $_,$_); |
| 74 | ok (${"$mbi\::div_scale"} = $_,$_); |
| 75 | } |
| 76 | # illegal values are possible for fallback due to no accessor |
| 77 | |
| 78 | # round_mode |
| 79 | foreach (qw/odd even zero trunc +inf -inf/) |
| 80 | { |
| 81 | ok (${"$mbf\::round_mode"} = $_,$_); |
| 82 | ok (${"$mbi\::round_mode"} = $_,$_); |
| 83 | } |
| 84 | ${"$mbf\::round_mode"} = 'zero'; |
| 85 | ok (${"$mbf\::round_mode"},'zero'); |
| 86 | ok (${"$mbi\::round_mode"},'-inf'); # from above |
| 87 | |
| 88 | ${"$mbi\::accuracy"} = undef; |
| 89 | ${"$mbi\::precision"} = undef; |
| 90 | # local copies |
| 91 | $x = $mbf->new('123.456'); |
| 92 | ok_undef ($x->accuracy()); |
| 93 | ok ($x->accuracy(5),5); |
| 94 | ok_undef ($x->accuracy(undef),undef); |
| 95 | ok_undef ($x->precision()); |
| 96 | ok ($x->precision(5),5); |
| 97 | ok_undef ($x->precision(undef),undef); |
| 98 | |
| 99 | # see if MBF changes MBIs values |
| 100 | ok (${"$mbi\::accuracy"} = 42,42); |
| 101 | ok (${"$mbf\::accuracy"} = 64,64); |
| 102 | ok (${"$mbi\::accuracy"},42); # should be still 42 |
| 103 | ok (${"$mbf\::accuracy"},64); # should be now 64 |
| 104 | |
| 105 | ############################################################################### |
| 106 | # see if creating a number under set A or P will round it |
| 107 | |
| 108 | ${"$mbi\::accuracy"} = 4; |
| 109 | ${"$mbi\::precision"} = undef; |
| 110 | |
| 111 | ok ($mbi->new(123456),123500); # with A |
| 112 | ${"$mbi\::accuracy"} = undef; |
| 113 | ${"$mbi\::precision"} = 3; |
| 114 | ok ($mbi->new(123456),123000); # with P |
| 115 | |
| 116 | ${"$mbf\::accuracy"} = 4; |
| 117 | ${"$mbf\::precision"} = undef; |
| 118 | ${"$mbi\::precision"} = undef; |
| 119 | |
| 120 | ok ($mbf->new('123.456'),'123.5'); # with A |
| 121 | ${"$mbf\::accuracy"} = undef; |
| 122 | ${"$mbf\::precision"} = -1; |
| 123 | ok ($mbf->new('123.456'),'123.5'); # with P from MBF, not MBI! |
| 124 | |
| 125 | ${"$mbf\::precision"} = undef; # reset |
| 126 | |
| 127 | ############################################################################### |
| 128 | # see if MBI leaves MBF's private parts alone |
| 129 | |
| 130 | ${"$mbi\::precision"} = undef; ${"$mbf\::precision"} = undef; |
| 131 | ${"$mbi\::accuracy"} = 4; ${"$mbf\::accuracy"} = undef; |
| 132 | ok (Math::BigFloat->new('123.456'),'123.456'); |
| 133 | ${"$mbi\::accuracy"} = undef; # reset |
| 134 | |
| 135 | ############################################################################### |
| 136 | # see if setting accuracy/precision actually rounds the number |
| 137 | |
| 138 | $x = $mbf->new('123.456'); $x->accuracy(4); ok ($x,'123.5'); |
| 139 | $x = $mbf->new('123.456'); $x->precision(-2); ok ($x,'123.46'); |
| 140 | |
| 141 | $x = $mbi->new(123456); $x->accuracy(4); ok ($x,123500); |
| 142 | $x = $mbi->new(123456); $x->precision(2); ok ($x,123500); |
| 143 | |
| 144 | ############################################################################### |
| 145 | # test actual rounding via round() |
| 146 | |
| 147 | $x = $mbf->new('123.456'); |
| 148 | ok ($x->copy()->round(5),'123.46'); |
| 149 | ok ($x->copy()->round(4),'123.5'); |
| 150 | ok ($x->copy()->round(5,2),'NaN'); |
| 151 | ok ($x->copy()->round(undef,-2),'123.46'); |
| 152 | ok ($x->copy()->round(undef,2),100); |
| 153 | |
| 154 | $x = $mbi->new('123'); |
| 155 | ok ($x->round(5,2),'NaN'); |
| 156 | |
| 157 | $x = $mbf->new('123.45000'); |
| 158 | ok ($x->copy()->round(undef,-1,'odd'),'123.5'); |
| 159 | |
| 160 | # see if rounding is 'sticky' |
| 161 | $x = $mbf->new('123.4567'); |
| 162 | $y = $x->copy()->bround(); # no-op since nowhere A or P defined |
| 163 | |
| 164 | ok ($y,123.4567); |
| 165 | $y = $x->copy()->round(5); |
| 166 | ok ($y->accuracy(),5); |
| 167 | ok_undef ($y->precision()); # A has precedence, so P still unset |
| 168 | $y = $x->copy()->round(undef,2); |
| 169 | ok ($y->precision(),2); |
| 170 | ok_undef ($y->accuracy()); # P has precedence, so A still unset |
| 171 | |
| 172 | # see if setting A clears P and vice versa |
| 173 | $x = $mbf->new('123.4567'); |
| 174 | ok ($x,'123.4567'); |
| 175 | ok ($x->accuracy(4),4); |
| 176 | ok ($x->precision(-2),-2); # clear A |
| 177 | ok_undef ($x->accuracy()); |
| 178 | |
| 179 | $x = $mbf->new('123.4567'); |
| 180 | ok ($x,'123.4567'); |
| 181 | ok ($x->precision(-2),-2); |
| 182 | ok ($x->accuracy(4),4); # clear P |
| 183 | ok_undef ($x->precision()); |
| 184 | |
| 185 | # does copy work? |
| 186 | $x = $mbf->new(123.456); $x->accuracy(4); $x->precision(2); |
| 187 | $z = $x->copy(); ok_undef ($z->accuracy(),undef); ok ($z->precision(),2); |
| 188 | |
| 189 | # does accuracy()/precision work on zeros? |
| 190 | foreach my $class ($mbi,$mbf) |
| 191 | { |
| 192 | $x = $class->bzero(); $x->accuracy(5); ok ($x->{_a},5); |
| 193 | $x = $class->bzero(); $x->precision(5); ok ($x->{_p},5); |
| 194 | $x = $class->new(0); $x->accuracy(5); ok ($x->{_a},5); |
| 195 | $x = $class->new(0); $x->precision(5); ok ($x->{_p},5); |
| 196 | |
| 197 | $x = $class->bzero(); $x->round(5); ok ($x->{_a},5); |
| 198 | $x = $class->bzero(); $x->round(undef,5); ok ($x->{_p},5); |
| 199 | $x = $class->new(0); $x->round(5); ok ($x->{_a},5); |
| 200 | $x = $class->new(0); $x->round(undef,5); ok ($x->{_p},5); |
| 201 | |
| 202 | # see if trying to increasing A in bzero() doesn't do something |
| 203 | $x = $class->bzero(); $x->{_a} = 3; $x->round(5); ok ($x->{_a},3); |
| 204 | } |
| 205 | |
| 206 | ############################################################################### |
| 207 | # test wether operations round properly afterwards |
| 208 | # These tests are not complete, since they do not excercise every "return" |
| 209 | # statement in the op's. But heh, it's better than nothing... |
| 210 | |
| 211 | $x = $mbf->new('123.456'); |
| 212 | $y = $mbf->new('654.321'); |
| 213 | $x->{_a} = 5; # $x->accuracy(5) would round $x straightaway |
| 214 | $y->{_a} = 4; # $y->accuracy(4) would round $x straightaway |
| 215 | |
| 216 | $z = $x + $y; ok ($z,'777.8'); |
| 217 | $z = $y - $x; ok ($z,'530.9'); |
| 218 | $z = $y * $x; ok ($z,'80780'); |
| 219 | $z = $x ** 2; ok ($z,'15241'); |
| 220 | $z = $x * $x; ok ($z,'15241'); |
| 221 | |
| 222 | # not: $z = -$x; ok ($z,'-123.46'); ok ($x,'123.456'); |
| 223 | $z = $x->copy(); $z->{_a} = 2; $z = $z / 2; ok ($z,62); |
| 224 | $x = $mbf->new(123456); $x->{_a} = 4; |
| 225 | $z = $x->copy; $z++; ok ($z,123500); |
| 226 | |
| 227 | $x = $mbi->new(123456); |
| 228 | $y = $mbi->new(654321); |
| 229 | $x->{_a} = 5; # $x->accuracy(5) would round $x straightaway |
| 230 | $y->{_a} = 4; # $y->accuracy(4) would round $x straightaway |
| 231 | |
| 232 | $z = $x + $y; ok ($z,777800); |
| 233 | $z = $y - $x; ok ($z,530900); |
| 234 | $z = $y * $x; ok ($z,80780000000); |
| 235 | $z = $x ** 2; ok ($z,15241000000); |
| 236 | # not yet: $z = -$x; ok ($z,-123460); ok ($x,123456); |
| 237 | $z = $x->copy; $z++; ok ($z,123460); |
| 238 | $z = $x->copy(); $z->{_a} = 2; $z = $z / 2; ok ($z,62000); |
| 239 | |
| 240 | $x = $mbi->new(123400); $x->{_a} = 4; |
| 241 | ok ($x->bnot(),-123400); # not -1234001 |
| 242 | |
| 243 | # both babs() and bneg() don't need to round, since the input will already |
| 244 | # be rounded (either as $x or via new($string)), and they don't change the |
| 245 | # value. The two tests below peek at this by using _a (illegally) directly |
| 246 | $x = $mbi->new(-123401); $x->{_a} = 4; ok ($x->babs(),123401); |
| 247 | $x = $mbi->new(-123401); $x->{_a} = 4; ok ($x->bneg(),123401); |
| 248 | |
| 249 | # test fdiv rounding to A and R (bug in v1.48 and maybe earlier versions) |
| 250 | $mbf->round_mode('even'); |
| 251 | $x = $mbf->new('740.7')->fdiv('6',4,undef,'zero'); ok ($x,'123.4'); |
| 252 | |
| 253 | ############################################################################### |
| 254 | # test mixed arguments |
| 255 | |
| 256 | $x = $mbf->new(10); |
| 257 | $u = $mbf->new(2.5); |
| 258 | $y = $mbi->new(2); |
| 259 | |
| 260 | $z = $x + $y; ok ($z,12); ok (ref($z),$mbf); |
| 261 | $z = $x / $y; ok ($z,5); ok (ref($z),$mbf); |
| 262 | $z = $u * $y; ok ($z,5); ok (ref($z),$mbf); |
| 263 | |
| 264 | $y = $mbi->new(12345); |
| 265 | $z = $u->copy()->bmul($y,2,undef,'odd'); ok ($z,31000); |
| 266 | $z = $u->copy()->bmul($y,3,undef,'odd'); ok ($z,30900); |
| 267 | $z = $u->copy()->bmul($y,undef,0,'odd'); ok ($z,30863); |
| 268 | $z = $u->copy()->bmul($y,undef,1,'odd'); ok ($z,30860); |
| 269 | $z = $u->copy()->bmul($y,undef,-1,'odd'); ok ($z,30862.5); |
| 270 | |
| 271 | # breakage: |
| 272 | # $z = $y->copy()->bmul($u,2,0,'odd'); ok ($z,31000); |
| 273 | # $z = $y * $u; ok ($z,5); ok (ref($z),$mbi); |
| 274 | # $z = $y + $x; ok ($z,12); ok (ref($z),$mbi); |
| 275 | # $z = $y / $x; ok ($z,0); ok (ref($z),$mbi); |
| 276 | |
| 277 | ############################################################################### |
| 278 | # rounding in bdiv with fallback and already set A or P |
| 279 | |
| 280 | ${"$mbf\::accuracy"} = undef; |
| 281 | ${"$mbf\::precision"} = undef; |
| 282 | ${"$mbf\::div_scale"} = 40; |
| 283 | |
| 284 | $x = $mbf->new(10); $x->{_a} = 4; |
| 285 | ok ($x->bdiv(3),'3.333'); |
| 286 | ok ($x->{_a},4); # set's it since no fallback |
| 287 | |
| 288 | $x = $mbf->new(10); $x->{_a} = 4; $y = $mbf->new(3); |
| 289 | ok ($x->bdiv($y),'3.333'); |
| 290 | ok ($x->{_a},4); # set's it since no fallback |
| 291 | |
| 292 | # rounding to P of x |
| 293 | $x = $mbf->new(10); $x->{_p} = -2; |
| 294 | ok ($x->bdiv(3),'3.33'); |
| 295 | |
| 296 | # round in div with requested P |
| 297 | $x = $mbf->new(10); |
| 298 | ok ($x->bdiv(3,undef,-2),'3.33'); |
| 299 | |
| 300 | # round in div with requested P greater than fallback |
| 301 | ${"$mbf\::div_scale"} = 5; |
| 302 | $x = $mbf->new(10); |
| 303 | ok ($x->bdiv(3,undef,-8),'3.33333333'); |
| 304 | ${"$mbf\::div_scale"} = 40; |
| 305 | |
| 306 | $x = $mbf->new(10); $y = $mbf->new(3); $y->{_a} = 4; |
| 307 | ok ($x->bdiv($y),'3.333'); |
| 308 | ok ($x->{_a},4); ok ($y->{_a},4); # set's it since no fallback |
| 309 | ok_undef ($x->{_p}); ok_undef ($y->{_p}); |
| 310 | |
| 311 | # rounding to P of y |
| 312 | $x = $mbf->new(10); $y = $mbf->new(3); $y->{_p} = -2; |
| 313 | ok ($x->bdiv($y),'3.33'); |
| 314 | ok ($x->{_p},-2); |
| 315 | ok ($y->{_p},-2); |
| 316 | ok_undef ($x->{_a}); ok_undef ($y->{_a}); |
| 317 | |
| 318 | ############################################################################### |
| 319 | # test whether bround(-n) fails in MBF (undocumented in MBI) |
| 320 | eval { $x = $mbf->new(1); $x->bround(-2); }; |
| 321 | ok ($@ =~ /^bround\(\) needs positive accuracy/,1); |
| 322 | |
| 323 | # test whether rounding to higher accuracy is no-op |
| 324 | $x = $mbf->new(1); $x->{_a} = 4; |
| 325 | ok ($x,'1.000'); |
| 326 | $x->bround(6); # must be no-op |
| 327 | ok ($x->{_a},4); |
| 328 | ok ($x,'1.000'); |
| 329 | |
| 330 | $x = $mbi->new(1230); $x->{_a} = 3; |
| 331 | ok ($x,'1230'); |
| 332 | $x->bround(6); # must be no-op |
| 333 | ok ($x->{_a},3); |
| 334 | ok ($x,'1230'); |
| 335 | |
| 336 | # bround(n) should set _a |
| 337 | $x->bround(2); # smaller works |
| 338 | ok ($x,'1200'); |
| 339 | ok ($x->{_a},2); |
| 340 | |
| 341 | # bround(-n) is undocumented and only used by MBF |
| 342 | # bround(-n) should set _a |
| 343 | $x = $mbi->new(12345); |
| 344 | $x->bround(-1); |
| 345 | ok ($x,'12300'); |
| 346 | ok ($x->{_a},4); |
| 347 | |
| 348 | # bround(-n) should set _a |
| 349 | $x = $mbi->new(12345); |
| 350 | $x->bround(-2); |
| 351 | ok ($x,'12000'); |
| 352 | ok ($x->{_a},3); |
| 353 | |
| 354 | # bround(-n) should set _a |
| 355 | $x = $mbi->new(12345); $x->{_a} = 5; |
| 356 | $x->bround(-3); |
| 357 | ok ($x,'10000'); |
| 358 | ok ($x->{_a},2); |
| 359 | |
| 360 | # bround(-n) should set _a |
| 361 | $x = $mbi->new(12345); $x->{_a} = 5; |
| 362 | $x->bround(-4); |
| 363 | ok ($x,'0'); |
| 364 | ok ($x->{_a},1); |
| 365 | |
| 366 | # bround(-n) should be noop if n too big |
| 367 | $x = $mbi->new(12345); |
| 368 | $x->bround(-5); |
| 369 | ok ($x,'0'); # scale to "big" => 0 |
| 370 | ok ($x->{_a},0); |
| 371 | |
| 372 | # bround(-n) should be noop if n too big |
| 373 | $x = $mbi->new(54321); |
| 374 | $x->bround(-5); |
| 375 | ok ($x,'100000'); # used by MBF to round 0.0054321 at 0.0_6_00000 |
| 376 | ok ($x->{_a},0); |
| 377 | |
| 378 | # bround(-n) should be noop if n too big |
| 379 | $x = $mbi->new(54321); $x->{_a} = 5; |
| 380 | $x->bround(-6); |
| 381 | ok ($x,'100000'); # no-op |
| 382 | ok ($x->{_a},0); |
| 383 | |
| 384 | # bround(n) should set _a |
| 385 | $x = $mbi->new(12345); $x->{_a} = 5; |
| 386 | $x->bround(5); # must be no-op |
| 387 | ok ($x,'12345'); |
| 388 | ok ($x->{_a},5); |
| 389 | |
| 390 | # bround(n) should set _a |
| 391 | $x = $mbi->new(12345); $x->{_a} = 5; |
| 392 | $x->bround(6); # must be no-op |
| 393 | ok ($x,'12345'); |
| 394 | |
| 395 | $x = $mbf->new('0.0061'); $x->bfround(-2); |
| 396 | ok ($x,'0.01'); |
| 397 | |
| 398 | # MBI::bfround should clear A for negative P |
| 399 | $x = $mbi->new('1234'); $x->accuracy(3); $x->bfround(-2); |
| 400 | ok_undef ($x->{_a}); |
| 401 | |
| 402 | ############################################################################### |
| 403 | # rounding with already set precision/accuracy |
| 404 | |
| 405 | $x = $mbf->new(1); $x->{_p} = -5; |
| 406 | ok ($x,'1.00000'); |
| 407 | |
| 408 | # further rounding donw |
| 409 | ok ($x->bfround(-2),'1.00'); |
| 410 | ok ($x->{_p},-2); |
| 411 | |
| 412 | $x = $mbf->new(12345); $x->{_a} = 5; |
| 413 | ok ($x->bround(2),'12000'); |
| 414 | ok ($x->{_a},2); |
| 415 | |
| 416 | $x = $mbf->new('1.2345'); $x->{_a} = 5; |
| 417 | ok ($x->bround(2),'1.2'); |
| 418 | ok ($x->{_a},2); |
| 419 | |
| 420 | # mantissa/exponent format and A/P |
| 421 | $x = $mbf->new('12345.678'); $x->accuracy(4); |
| 422 | ok ($x,'12350'); ok ($x->{_a},4); ok_undef ($x->{_p}); |
| 423 | ok_undef ($x->{_m}->{_a}); ok_undef ($x->{_e}->{_a}); |
| 424 | ok_undef ($x->{_m}->{_p}); ok_undef ($x->{_e}->{_p}); |
| 425 | |
| 426 | # check for no A/P in case of fallback |
| 427 | # result |
| 428 | $x = $mbf->new(100) / 3; |
| 429 | ok_undef ($x->{_a}); ok_undef ($x->{_p}); |
| 430 | |
| 431 | # result & reminder |
| 432 | $x = $mbf->new(100) / 3; ($x,$y) = $x->bdiv(3); |
| 433 | ok_undef ($x->{_a}); ok_undef ($x->{_p}); |
| 434 | ok_undef ($y->{_a}); ok_undef ($y->{_p}); |
| 435 | |
| 436 | ############################################################################### |
| 437 | # math with two numbers with differen A and P |
| 438 | |
| 439 | $x = $mbf->new(12345); $x->accuracy(4); # '12340' |
| 440 | $y = $mbf->new(12345); $y->accuracy(2); # '12000' |
| 441 | ok ($x+$y,24000); # 12340+12000=> 24340 => 24000 |
| 442 | |
| 443 | $x = $mbf->new(54321); $x->accuracy(4); # '12340' |
| 444 | $y = $mbf->new(12345); $y->accuracy(3); # '12000' |
| 445 | ok ($x-$y,42000); # 54320+12300=> 42020 => 42000 |
| 446 | |
| 447 | $x = $mbf->new('1.2345'); $x->precision(-2); # '1.23' |
| 448 | $y = $mbf->new('1.2345'); $y->precision(-4); # '1.2345' |
| 449 | ok ($x+$y,'2.46'); # 1.2345+1.2300=> 2.4645 => 2.46 |
| 450 | |
| 451 | ############################################################################### |
| 452 | # round should find and use proper class |
| 453 | |
| 454 | #$x = Foo->new(); |
| 455 | #ok ($x->round($Foo::accuracy),'a' x $Foo::accuracy); |
| 456 | #ok ($x->round(undef,$Foo::precision),'p' x $Foo::precision); |
| 457 | #ok ($x->bfround($Foo::precision),'p' x $Foo::precision); |
| 458 | #ok ($x->bround($Foo::accuracy),'a' x $Foo::accuracy); |
| 459 | |
| 460 | ############################################################################### |
| 461 | # find out whether _find_round_parameters is doing what's it's supposed to do |
| 462 | |
| 463 | ${"$mbi\::accuracy"} = undef; |
| 464 | ${"$mbi\::precision"} = undef; |
| 465 | ${"$mbi\::div_scale"} = 40; |
| 466 | ${"$mbi\::round_mode"} = 'odd'; |
| 467 | |
| 468 | $x = $mbi->new(123); |
| 469 | my @params = $x->_find_round_parameters(); |
| 470 | ok (scalar @params,1); # nothing to round |
| 471 | |
| 472 | @params = $x->_find_round_parameters(1); |
| 473 | ok (scalar @params,4); # a=1 |
| 474 | ok ($params[0],$x); # self |
| 475 | ok ($params[1],1); # a |
| 476 | ok_undef ($params[2]); # p |
| 477 | ok ($params[3],'odd'); # round_mode |
| 478 | |
| 479 | @params = $x->_find_round_parameters(undef,2); |
| 480 | ok (scalar @params,4); # p=2 |
| 481 | ok ($params[0],$x); # self |
| 482 | ok_undef ($params[1]); # a |
| 483 | ok ($params[2],2); # p |
| 484 | ok ($params[3],'odd'); # round_mode |
| 485 | |
| 486 | eval { @params = $x->_find_round_parameters(undef,2,'foo'); }; |
| 487 | ok ($@ =~ /^Unknown round mode 'foo'/,1); |
| 488 | |
| 489 | @params = $x->_find_round_parameters(undef,2,'+inf'); |
| 490 | ok (scalar @params,4); # p=2 |
| 491 | ok ($params[0],$x); # self |
| 492 | ok_undef ($params[1]); # a |
| 493 | ok ($params[2],2); # p |
| 494 | ok ($params[3],'+inf'); # round_mode |
| 495 | |
| 496 | @params = $x->_find_round_parameters(2,-2,'+inf'); |
| 497 | ok (scalar @params,1); # error, A and P defined |
| 498 | ok ($params[0],$x); # self |
| 499 | |
| 500 | ${"$mbi\::accuracy"} = 1; |
| 501 | @params = $x->_find_round_parameters(undef,-2); |
| 502 | ok (scalar @params,1); # error, A and P defined |
| 503 | ok ($params[0],$x); # self |
| 504 | |
| 505 | ${"$mbi\::accuracy"} = undef; |
| 506 | ${"$mbi\::precision"} = 1; |
| 507 | @params = $x->_find_round_parameters(1,undef); |
| 508 | ok (scalar @params,1); # error, A and P defined |
| 509 | ok ($params[0],$x); # self |
| 510 | |
| 511 | ${"$mbi\::precision"} = undef; # reset |
| 512 | |
| 513 | ############################################################################### |
| 514 | # test whether bone/bzero take additional A & P, or reset it etc |
| 515 | |
| 516 | foreach my $class ($mbi,$mbf) |
| 517 | { |
| 518 | $x = $class->new(2)->bzero(); ok_undef ($x->{_a}); ok_undef ($x->{_p}); |
| 519 | $x = $class->new(2)->bone(); ok_undef ($x->{_a}); ok_undef ($x->{_p}); |
| 520 | $x = $class->new(2)->binf(); ok_undef ($x->{_a}); ok_undef ($x->{_p}); |
| 521 | $x = $class->new(2)->bnan(); ok_undef ($x->{_a}); ok_undef ($x->{_p}); |
| 522 | |
| 523 | $x = $class->new(2); $x->{_a} = 1; $x->{_p} = 2; $x->bnan(); |
| 524 | ok_undef ($x->{_a}); ok_undef ($x->{_p}); |
| 525 | $x = $class->new(2); $x->{_a} = 1; $x->{_p} = 2; $x->binf(); |
| 526 | ok_undef ($x->{_a}); ok_undef ($x->{_p}); |
| 527 | |
| 528 | $x = $class->new(2,1); ok ($x->{_a},1); ok_undef ($x->{_p}); |
| 529 | $x = $class->new(2,undef,1); ok_undef ($x->{_a}); ok ($x->{_p},1); |
| 530 | |
| 531 | $x = $class->new(2,1)->bzero(); ok ($x->{_a},1); ok_undef ($x->{_p}); |
| 532 | $x = $class->new(2,undef,1)->bzero(); ok_undef ($x->{_a}); ok ($x->{_p},1); |
| 533 | |
| 534 | $x = $class->new(2,1)->bone(); ok ($x->{_a},1); ok_undef ($x->{_p}); |
| 535 | $x = $class->new(2,undef,1)->bone(); ok_undef ($x->{_a}); ok ($x->{_p},1); |
| 536 | } |
| 537 | |
| 538 | ############################################################################### |
| 539 | # check whether mixing A and P creates a NaN |
| 540 | |
| 541 | # new with set accuracy/precision and with parameters |
| 542 | |
| 543 | foreach my $class ($mbi,$mbf) |
| 544 | { |
| 545 | ok ($class->new(123,4,-3),'NaN'); # with parameters |
| 546 | ${"$class\::accuracy"} = 42; |
| 547 | ${"$class\::precision"} = 2; |
| 548 | ok ($class->new(123),'NaN'); # with globals |
| 549 | ${"$class\::accuracy"} = undef; |
| 550 | ${"$class\::precision"} = undef; |
| 551 | } |
| 552 | |
| 553 | # binary ops |
| 554 | foreach my $class ($mbi,$mbf) |
| 555 | { |
| 556 | foreach (qw/add sub mul pow mod/) |
| 557 | #foreach (qw/add sub mul div pow mod/) |
| 558 | { |
| 559 | my $try = "my \$x = $class->new(1234); \$x->accuracy(5); "; |
| 560 | $try .= "my \$y = $class->new(12); \$y->precision(-3); "; |
| 561 | $try .= "\$x->b$_(\$y);"; |
| 562 | $rc = eval $try; |
| 563 | print "# Tried: '$try'\n" if !ok ($rc, 'NaN'); |
| 564 | } |
| 565 | } |
| 566 | |
| 567 | # unary ops |
| 568 | foreach (qw/new bsqrt/) |
| 569 | { |
| 570 | my $try = 'my $x = $mbi->$_(1234,5,-3); '; |
| 571 | $rc = eval $try; |
| 572 | print "# Tried: '$try'\n" if !ok ($rc, 'NaN'); |
| 573 | } |
| 574 | |
| 575 | ############################################################################### |
| 576 | # test whether shortcuts returning zero/one preserve A and P |
| 577 | |
| 578 | my ($ans1,$f,$a,$p,$xp,$yp,$xa,$ya,$try,$ans,@args); |
| 579 | my $CALC = Math::BigInt::_core_lib(); |
| 580 | while (<DATA>) |
| 581 | { |
| 582 | chop; |
| 583 | next if /^\s*(#|$)/; # skip comments and empty lines |
| 584 | if (s/^&//) |
| 585 | { |
| 586 | $f = $_; next; # function |
| 587 | } |
| 588 | @args = split(/:/,$_,99); |
| 589 | my $ans = pop(@args); |
| 590 | |
| 591 | ($x,$xa,$xp) = split (/,/,$args[0]); |
| 592 | $xa = $xa || ''; $xp = $xp || ''; |
| 593 | $try = "\$x = $mbi->new('$x'); "; |
| 594 | $try .= "\$x->accuracy($xa); " if $xa ne ''; |
| 595 | $try .= "\$x->precision($xp); " if $xp ne ''; |
| 596 | |
| 597 | ($y,$ya,$yp) = split (/,/,$args[1]); |
| 598 | $ya = $ya || ''; $yp = $yp || ''; |
| 599 | $try .= "\$y = $mbi->new('$y'); "; |
| 600 | $try .= "\$y->accuracy($ya); " if $ya ne ''; |
| 601 | $try .= "\$y->precision($yp); " if $yp ne ''; |
| 602 | |
| 603 | $try .= "\$x->$f(\$y);"; |
| 604 | |
| 605 | # print "trying $try\n"; |
| 606 | $rc = eval $try; |
| 607 | # convert hex/binary targets to decimal |
| 608 | if ($ans =~ /^(0x0x|0b0b)/) |
| 609 | { |
| 610 | $ans =~ s/^0[xb]//; |
| 611 | $ans = $mbi->new($ans)->bstr(); |
| 612 | } |
| 613 | print "# Tried: '$try'\n" if !ok ($rc, $ans); |
| 614 | # check internal state of number objects |
| 615 | is_valid($rc,$f) if ref $rc; |
| 616 | |
| 617 | # now check whether A and P are set correctly |
| 618 | # only one of $a or $p will be set (no crossing here) |
| 619 | $a = $xa || $ya; $p = $xp || $yp; |
| 620 | |
| 621 | # print "Check a=$a p=$p\n"; |
| 622 | print "# Tried: '$try'\n"; |
| 623 | ok ($x->{_a}, $a) && ok_undef ($x->{_p}) if $a ne ''; |
| 624 | ok ($x->{_p}, $p) && ok_undef ($x->{_a}) if $p ne ''; |
| 625 | } |
| 626 | |
| 627 | # all done |
| 628 | 1; |
| 629 | |
| 630 | ############################################################################### |
| 631 | ############################################################################### |
| 632 | # Perl 5.005 does not like ok ($x,undef) |
| 633 | |
| 634 | sub ok_undef |
| 635 | { |
| 636 | my $x = shift; |
| 637 | |
| 638 | ok (1,1) and return if !defined $x; |
| 639 | ok ($x,'undef'); |
| 640 | print "# Called from ",join(' ',caller()),"\n"; |
| 641 | } |
| 642 | |
| 643 | ############################################################################### |
| 644 | # sub to check validity of a BigInt internally, to ensure that no op leaves a |
| 645 | # number object in an invalid state (f.i. "-0") |
| 646 | |
| 647 | sub is_valid |
| 648 | { |
| 649 | my ($x,$f) = @_; |
| 650 | |
| 651 | my $e = 0; # error? |
| 652 | # ok as reference? |
| 653 | $e = 'Not a reference' if !ref($x); |
| 654 | |
| 655 | # has ok sign? |
| 656 | $e = "Illegal sign $x->{sign} (expected: '+', '-', '-inf', '+inf' or 'NaN'" |
| 657 | if $e eq '0' && $x->{sign} !~ /^(\+|-|\+inf|-inf|NaN)$/; |
| 658 | |
| 659 | $e = "-0 is invalid!" if $e ne '0' && $x->{sign} eq '-' && $x == 0; |
| 660 | $e = $CALC->_check($x->{value}) if $e eq '0'; |
| 661 | |
| 662 | # test done, see if error did crop up |
| 663 | ok (1,1), return if ($e eq '0'); |
| 664 | |
| 665 | ok (1,$e." after op '$f'"); |
| 666 | } |
| 667 | |
| 668 | # format is: |
| 669 | # x,A,P:x,A,P:result |
| 670 | # 123,,3 means 123 with precision 3 (A is undef) |
| 671 | # the A or P of the result is calculated automatically |
| 672 | __DATA__ |
| 673 | &badd |
| 674 | # bsub uses badd anyway, so it should be right |
| 675 | 123,,:123,,:246 |
| 676 | 123,3,:0,,:123 |
| 677 | 123,,-3:0,,:123 |
| 678 | 123,,:0,3,:123 |
| 679 | 123,,:0,,-3:123 |
| 680 | &bmul |
| 681 | 123,,:1,,:123 |
| 682 | 123,3,:0,,:0 |
| 683 | 123,,-3:0,,:0 |
| 684 | 123,,:0,3,:0 |
| 685 | 123,,:0,,-3:0 |
| 686 | 123,3,:1,,:123 |
| 687 | 123,,-3:1,,:123 |
| 688 | 123,,:1,3,:123 |
| 689 | 123,,:1,,-3:123 |
| 690 | 1,3,:123,,:123 |
| 691 | 1,,-3:123,,:123 |
| 692 | 1,,:123,3,:123 |
| 693 | 1,,:123,,-3:123 |
| 694 | &bdiv |
| 695 | 123,,:1,,:123 |
| 696 | 123,4,:1,,:123 |
| 697 | 123,,:1,4,:123 |
| 698 | 123,,:1,,-4:123 |
| 699 | 123,,-4:1,,:123 |
| 700 | 1,4,:123,,:0 |
| 701 | 1,,:123,4,:0 |
| 702 | 1,,:123,,-4:0 |
| 703 | 1,,-4:123,,:0 |
projects / p5sagit/p5-mst-13.2.git / blame