This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade Math::BigInt from 1.999701 to 1.999704
[perl5.git] / cpan / Math-BigInt / lib / Math / BigInt.pm
CommitLineData
13a12e00
JH
1package Math::BigInt;
2
3#
4# "Mike had an infinite amount to do and a negative amount of time in which
5# to do it." - Before and After
6#
7
58cde26e 8# The following hash values are used:
9681bfa6 9# value: unsigned int with actual value (as a Math::BigInt::Calc or similar)
58cde26e
JH
10# sign : +,-,NaN,+inf,-inf
11# _a : accuracy
12# _p : precision
0716bf9b 13# _f : flags, used by MBF to flag parts of a float as untouchable
b4f14daa 14
574bacfe
JH
15# Remember not to take shortcuts ala $xs = $x->{value}; $CALC->foo($xs); since
16# underlying lib might change the reference!
17
58cde26e 18my $class = "Math::BigInt";
0d71d61a 19use 5.006002;
58cde26e 20
06ce15ad 21$VERSION = '1.999704';
b68b7ab1 22
233f7bc0
T
23@ISA = qw(Exporter);
24@EXPORT_OK = qw(objectify bgcd blcm);
b68b7ab1 25
b282a552
T
26# _trap_inf and _trap_nan are internal and should never be accessed from the
27# outside
28use vars qw/$round_mode $accuracy $precision $div_scale $rnd_mode
29 $upgrade $downgrade $_trap_nan $_trap_inf/;
58cde26e
JH
30use strict;
31
32# Inside overload, the first arg is always an object. If the original code had
df0693ed 33# it reversed (like $x = 2 * $y), then the third parameter is true.
091c87b1
T
34# In some cases (like add, $x = $x + 2 is the same as $x = 2 + $x) this makes
35# no difference, but in some cases it does.
58cde26e
JH
36
37# For overloaded ops with only one argument we simple use $_[0]->copy() to
38# preserve the argument.
39
40# Thus inheritance of overload operators becomes possible and transparent for
41# our subclasses without the need to repeat the entire overload section there.
a0d0e21e 42
5e0688b6
FC
43# We register ops that are not registerable yet, so suppress warnings
44{ no warnings;
a5f75d66 45use overload
58cde26e
JH
46'=' => sub { $_[0]->copy(); },
47
58cde26e
JH
48# some shortcuts for speed (assumes that reversed order of arguments is routed
49# to normal '+' and we thus can always modify first arg. If this is changed,
50# this breaks and must be adjusted.)
51'+=' => sub { $_[0]->badd($_[1]); },
52'-=' => sub { $_[0]->bsub($_[1]); },
53'*=' => sub { $_[0]->bmul($_[1]); },
54'/=' => sub { scalar $_[0]->bdiv($_[1]); },
027dc388
JH
55'%=' => sub { $_[0]->bmod($_[1]); },
56'^=' => sub { $_[0]->bxor($_[1]); },
57'&=' => sub { $_[0]->band($_[1]); },
58'|=' => sub { $_[0]->bior($_[1]); },
58cde26e 59
b68b7ab1 60'**=' => sub { $_[0]->bpow($_[1]); },
2d2b2744
T
61'<<=' => sub { $_[0]->blsft($_[1]); },
62'>>=' => sub { $_[0]->brsft($_[1]); },
63
b3abae2a 64# not supported by Perl yet
027dc388
JH
65'..' => \&_pointpoint,
66
a0ac753d 67'<=>' => sub { my $rc = $_[2] ?
bd05a461 68 ref($_[0])->bcmp($_[1],$_[0]) :
a0ac753d
T
69 $_[0]->bcmp($_[1]);
70 $rc = 1 unless defined $rc;
71 $rc <=> 0;
72 },
73# we need '>=' to get things like "1 >= NaN" right:
74'>=' => sub { my $rc = $_[2] ?
75 ref($_[0])->bcmp($_[1],$_[0]) :
76 $_[0]->bcmp($_[1]);
77 # if there was a NaN involved, return false
78 return '' unless defined $rc;
79 $rc >= 0;
80 },
027dc388 81'cmp' => sub {
58cde26e 82 $_[2] ?
b3abae2a
JH
83 "$_[1]" cmp $_[0]->bstr() :
84 $_[0]->bstr() cmp "$_[1]" },
58cde26e 85
60a1aa19
T
86'cos' => sub { $_[0]->copy->bcos(); },
87'sin' => sub { $_[0]->copy->bsin(); },
a87115f0 88'atan2' => sub { $_[2] ?
20e2035c
T
89 ref($_[0])->new($_[1])->batan2($_[0]) :
90 $_[0]->copy()->batan2($_[1]) },
091c87b1 91
b68b7ab1
T
92# are not yet overloadable
93#'hex' => sub { print "hex"; $_[0]; },
94#'oct' => sub { print "oct"; $_[0]; },
95
a0ac753d 96# log(N) is log(N, e), where e is Euler's number
06ce15ad 97'log' => sub { $_[0]->copy()->blog(); },
7d193e39 98'exp' => sub { $_[0]->copy()->bexp($_[1]); },
58cde26e
JH
99'int' => sub { $_[0]->copy(); },
100'neg' => sub { $_[0]->copy()->bneg(); },
101'abs' => sub { $_[0]->copy()->babs(); },
b3abae2a 102'sqrt' => sub { $_[0]->copy()->bsqrt(); },
58cde26e
JH
103'~' => sub { $_[0]->copy()->bnot(); },
104
12fc2493 105# for subtract it's a bit tricky to not modify b: b-a => -a+b
091c87b1 106'-' => sub { my $c = $_[0]->copy; $_[2] ?
a87115f0
RGS
107 $c->bneg()->badd( $_[1]) :
108 $c->bsub( $_[1]) },
091c87b1
T
109'+' => sub { $_[0]->copy()->badd($_[1]); },
110'*' => sub { $_[0]->copy()->bmul($_[1]); },
111
112'/' => sub {
113 $_[2] ? ref($_[0])->new($_[1])->bdiv($_[0]) : $_[0]->copy->bdiv($_[1]);
114 },
115'%' => sub {
116 $_[2] ? ref($_[0])->new($_[1])->bmod($_[0]) : $_[0]->copy->bmod($_[1]);
117 },
118'**' => sub {
119 $_[2] ? ref($_[0])->new($_[1])->bpow($_[0]) : $_[0]->copy->bpow($_[1]);
120 },
121'<<' => sub {
122 $_[2] ? ref($_[0])->new($_[1])->blsft($_[0]) : $_[0]->copy->blsft($_[1]);
123 },
124'>>' => sub {
125 $_[2] ? ref($_[0])->new($_[1])->brsft($_[0]) : $_[0]->copy->brsft($_[1]);
126 },
127'&' => sub {
128 $_[2] ? ref($_[0])->new($_[1])->band($_[0]) : $_[0]->copy->band($_[1]);
129 },
130'|' => sub {
131 $_[2] ? ref($_[0])->new($_[1])->bior($_[0]) : $_[0]->copy->bior($_[1]);
132 },
133'^' => sub {
134 $_[2] ? ref($_[0])->new($_[1])->bxor($_[0]) : $_[0]->copy->bxor($_[1]);
135 },
136
137# can modify arg of ++ and --, so avoid a copy() for speed, but don't
138# use $_[0]->bone(), it would modify $_[0] to be 1!
58cde26e
JH
139'++' => sub { $_[0]->binc() },
140'--' => sub { $_[0]->bdec() },
141
142# if overloaded, O(1) instead of O(N) and twice as fast for small numbers
143'bool' => sub {
144 # this kludge is needed for perl prior 5.6.0 since returning 0 here fails :-/
091c87b1 145 # v5.6.1 dumps on this: return !$_[0]->is_zero() || undef; :-(
3a427a11
RGS
146 my $t = undef;
147 $t = 1 if !$_[0]->is_zero();
b3abae2a 148 $t;
58cde26e 149 },
a0d0e21e 150
027dc388 151# the original qw() does not work with the TIESCALAR below, why?
ada8209b 152# Order of arguments insignificant
027dc388
JH
153'""' => sub { $_[0]->bstr(); },
154'0+' => sub { $_[0]->numify(); }
a5f75d66 155;
5e0688b6 156} # no warnings scope
a0d0e21e 157
58cde26e
JH
158##############################################################################
159# global constants, flags and accessory
160
b68b7ab1
T
161# These vars are public, but their direct usage is not recommended, use the
162# accessor methods instead
0716bf9b 163
7b29e1e6 164$round_mode = 'even'; # one of 'even', 'odd', '+inf', '-inf', 'zero', 'trunc' or 'common'
ee15d750
JH
165$accuracy = undef;
166$precision = undef;
167$div_scale = 40;
58cde26e 168
b3abae2a
JH
169$upgrade = undef; # default is no upgrade
170$downgrade = undef; # default is no downgrade
171
b68b7ab1 172# These are internally, and not to be used from the outside at all
990fb837
RGS
173
174$_trap_nan = 0; # are NaNs ok? set w/ config()
175$_trap_inf = 0; # are infs ok? set w/ config()
176my $nan = 'NaN'; # constants for easier life
177
a90064ab
PJA
178my $CALC = 'Math::BigInt::Calc'; # module to do the low level math
179 # default is Calc.pm
990fb837
RGS
180my $IMPORT = 0; # was import() called yet?
181 # used to make require work
9b924220
RGS
182my %WARN; # warn only once for low-level libs
183my %CAN; # cache for $CALC->can(...)
b68b7ab1 184my %CALLBACKS; # callbacks to notify on lib loads
b282a552 185my $EMU_LIB = 'Math/BigInt/CalcEmu.pm'; # emulate low-level math
b282a552 186
027dc388
JH
187##############################################################################
188# the old code had $rnd_mode, so we need to support it, too
189
190$rnd_mode = 'even';
191sub TIESCALAR { my ($class) = @_; bless \$round_mode, $class; }
192sub FETCH { return $round_mode; }
193sub STORE { $rnd_mode = $_[0]->round_mode($_[1]); }
194
b282a552
T
195BEGIN
196 {
197 # tie to enable $rnd_mode to work transparently
198 tie $rnd_mode, 'Math::BigInt';
199
200 # set up some handy alias names
201 *as_int = \&as_number;
202 *is_pos = \&is_positive;
203 *is_neg = \&is_negative;
204 }
027dc388
JH
205
206##############################################################################
207
58cde26e
JH
208sub round_mode
209 {
ee15d750 210 no strict 'refs';
58cde26e 211 # make Class->round_mode() work
ee15d750
JH
212 my $self = shift;
213 my $class = ref($self) || $self || __PACKAGE__;
58cde26e
JH
214 if (defined $_[0])
215 {
216 my $m = shift;
7b29e1e6 217 if ($m !~ /^(even|odd|\+inf|\-inf|zero|trunc|common)$/)
990fb837
RGS
218 {
219 require Carp; Carp::croak ("Unknown round mode '$m'");
220 }
b3abae2a 221 return ${"${class}::round_mode"} = $m;
58cde26e 222 }
990fb837 223 ${"${class}::round_mode"};
ee15d750
JH
224 }
225
b3abae2a
JH
226sub upgrade
227 {
228 no strict 'refs';
28df3e88 229 # make Class->upgrade() work
b3abae2a
JH
230 my $self = shift;
231 my $class = ref($self) || $self || __PACKAGE__;
9393ace2
JH
232 # need to set new value?
233 if (@_ > 0)
b3abae2a 234 {
b68b7ab1 235 return ${"${class}::upgrade"} = $_[0];
b3abae2a 236 }
990fb837 237 ${"${class}::upgrade"};
b3abae2a
JH
238 }
239
28df3e88
JH
240sub downgrade
241 {
242 no strict 'refs';
243 # make Class->downgrade() work
244 my $self = shift;
245 my $class = ref($self) || $self || __PACKAGE__;
9393ace2
JH
246 # need to set new value?
247 if (@_ > 0)
28df3e88 248 {
b68b7ab1 249 return ${"${class}::downgrade"} = $_[0];
28df3e88 250 }
990fb837 251 ${"${class}::downgrade"};
28df3e88
JH
252 }
253
ee15d750
JH
254sub div_scale
255 {
256 no strict 'refs';
990fb837 257 # make Class->div_scale() work
ee15d750
JH
258 my $self = shift;
259 my $class = ref($self) || $self || __PACKAGE__;
260 if (defined $_[0])
261 {
990fb837
RGS
262 if ($_[0] < 0)
263 {
264 require Carp; Carp::croak ('div_scale must be greater than zero');
265 }
b68b7ab1 266 ${"${class}::div_scale"} = $_[0];
ee15d750 267 }
990fb837 268 ${"${class}::div_scale"};
58cde26e
JH
269 }
270
271sub accuracy
272 {
ee15d750
JH
273 # $x->accuracy($a); ref($x) $a
274 # $x->accuracy(); ref($x)
275 # Class->accuracy(); class
276 # Class->accuracy($a); class $a
58cde26e 277
ee15d750
JH
278 my $x = shift;
279 my $class = ref($x) || $x || __PACKAGE__;
58cde26e 280
ee15d750
JH
281 no strict 'refs';
282 # need to set new value?
58cde26e
JH
283 if (@_ > 0)
284 {
ee15d750 285 my $a = shift;
990fb837
RGS
286 # convert objects to scalars to avoid deep recursion. If object doesn't
287 # have numify(), then hopefully it will have overloading for int() and
288 # boolean test without wandering into a deep recursion path...
289 $a = $a->numify() if ref($a) && $a->can('numify');
290
291 if (defined $a)
292 {
293 # also croak on non-numerical
294 if (!$a || $a <= 0)
295 {
296 require Carp;
d5351619 297 Carp::croak ('Argument to accuracy must be greater than zero');
990fb837
RGS
298 }
299 if (int($a) != $a)
300 {
d5351619
T
301 require Carp;
302 Carp::croak ('Argument to accuracy must be an integer');
990fb837
RGS
303 }
304 }
ee15d750
JH
305 if (ref($x))
306 {
307 # $object->accuracy() or fallback to global
ef9466ea
T
308 $x->bround($a) if $a; # not for undef, 0
309 $x->{_a} = $a; # set/overwrite, even if not rounded
310 delete $x->{_p}; # clear P
990fb837 311 $a = ${"${class}::accuracy"} unless defined $a; # proper return value
ee15d750
JH
312 }
313 else
314 {
ef9466ea
T
315 ${"${class}::accuracy"} = $a; # set global A
316 ${"${class}::precision"} = undef; # clear global P
ee15d750 317 }
ef9466ea 318 return $a; # shortcut
ee15d750
JH
319 }
320
b68b7ab1 321 my $a;
f9a08e12 322 # $object->accuracy() or fallback to global
b68b7ab1 323 $a = $x->{_a} if ref($x);
f9a08e12 324 # but don't return global undef, when $x's accuracy is 0!
b68b7ab1
T
325 $a = ${"${class}::accuracy"} if !defined $a;
326 $a;
990fb837 327 }
58cde26e
JH
328
329sub precision
330 {
ee15d750
JH
331 # $x->precision($p); ref($x) $p
332 # $x->precision(); ref($x)
333 # Class->precision(); class
334 # Class->precision($p); class $p
58cde26e 335
ee15d750
JH
336 my $x = shift;
337 my $class = ref($x) || $x || __PACKAGE__;
58cde26e 338
ee15d750 339 no strict 'refs';
58cde26e
JH
340 if (@_ > 0)
341 {
ee15d750 342 my $p = shift;
990fb837
RGS
343 # convert objects to scalars to avoid deep recursion. If object doesn't
344 # have numify(), then hopefully it will have overloading for int() and
345 # boolean test without wandering into a deep recursion path...
346 $p = $p->numify() if ref($p) && $p->can('numify');
347 if ((defined $p) && (int($p) != $p))
348 {
349 require Carp; Carp::croak ('Argument to precision must be an integer');
350 }
ee15d750
JH
351 if (ref($x))
352 {
353 # $object->precision() or fallback to global
ef9466ea
T
354 $x->bfround($p) if $p; # not for undef, 0
355 $x->{_p} = $p; # set/overwrite, even if not rounded
356 delete $x->{_a}; # clear A
990fb837 357 $p = ${"${class}::precision"} unless defined $p; # proper return value
ee15d750
JH
358 }
359 else
360 {
ef9466ea
T
361 ${"${class}::precision"} = $p; # set global P
362 ${"${class}::accuracy"} = undef; # clear global A
ee15d750 363 }
ef9466ea 364 return $p; # shortcut
58cde26e 365 }
ee15d750 366
b68b7ab1 367 my $p;
f9a08e12 368 # $object->precision() or fallback to global
b68b7ab1 369 $p = $x->{_p} if ref($x);
f9a08e12 370 # but don't return global undef, when $x's precision is 0!
b68b7ab1
T
371 $p = ${"${class}::precision"} if !defined $p;
372 $p;
990fb837 373 }
58cde26e 374
b3abae2a
JH
375sub config
376 {
990fb837 377 # return (or set) configuration data as hash ref
b3abae2a
JH
378 my $class = shift || 'Math::BigInt';
379
380 no strict 'refs';
2ebb273f 381 if (@_ > 1 || (@_ == 1 && (ref($_[0]) eq 'HASH')))
990fb837
RGS
382 {
383 # try to set given options as arguments from hash
384
385 my $args = $_[0];
386 if (ref($args) ne 'HASH')
387 {
388 $args = { @_ };
389 }
390 # these values can be "set"
391 my $set_args = {};
392 foreach my $key (
393 qw/trap_inf trap_nan
394 upgrade downgrade precision accuracy round_mode div_scale/
395 )
396 {
397 $set_args->{$key} = $args->{$key} if exists $args->{$key};
398 delete $args->{$key};
399 }
400 if (keys %$args > 0)
401 {
402 require Carp;
403 Carp::croak ("Illegal key(s) '",
404 join("','",keys %$args),"' passed to $class\->config()");
405 }
406 foreach my $key (keys %$set_args)
407 {
408 if ($key =~ /^trap_(inf|nan)\z/)
409 {
410 ${"${class}::_trap_$1"} = ($set_args->{"trap_$1"} ? 1 : 0);
411 next;
412 }
413 # use a call instead of just setting the $variable to check argument
414 $class->$key($set_args->{$key});
415 }
416 }
417
418 # now return actual configuration
419
b3abae2a 420 my $cfg = {
990fb837
RGS
421 lib => $CALC,
422 lib_version => ${"${CALC}::VERSION"},
b3abae2a 423 class => $class,
990fb837
RGS
424 trap_nan => ${"${class}::_trap_nan"},
425 trap_inf => ${"${class}::_trap_inf"},
426 version => ${"${class}::VERSION"},
b3abae2a 427 };
990fb837
RGS
428 foreach my $key (qw/
429 upgrade downgrade precision accuracy round_mode div_scale
430 /)
b3abae2a 431 {
990fb837 432 $cfg->{$key} = ${"${class}::$key"};
b3abae2a 433 };
2ebb273f
T
434 if (@_ == 1 && (ref($_[0]) ne 'HASH'))
435 {
436 # calls of the style config('lib') return just this value
437 return $cfg->{$_[0]};
438 }
b3abae2a
JH
439 $cfg;
440 }
441
58cde26e
JH
442sub _scale_a
443 {
444 # select accuracy parameter based on precedence,
445 # used by bround() and bfround(), may return undef for scale (means no op)
b68b7ab1
T
446 my ($x,$scale,$mode) = @_;
447
448 $scale = $x->{_a} unless defined $scale;
449
450 no strict 'refs';
451 my $class = ref($x);
452
453 $scale = ${ $class . '::accuracy' } unless defined $scale;
454 $mode = ${ $class . '::round_mode' } unless defined $mode;
455
d5351619
T
456 if (defined $scale)
457 {
1aa3c823
JK
458 $scale = $scale->can('numify') ? $scale->numify()
459 : "$scale" if ref($scale);
d5351619
T
460 $scale = int($scale);
461 }
462
b68b7ab1 463 ($scale,$mode);
58cde26e
JH
464 }
465
466sub _scale_p
467 {
468 # select precision parameter based on precedence,
469 # used by bround() and bfround(), may return undef for scale (means no op)
b68b7ab1 470 my ($x,$scale,$mode) = @_;
1aa3c823 471
b68b7ab1
T
472 $scale = $x->{_p} unless defined $scale;
473
474 no strict 'refs';
475 my $class = ref($x);
476
477 $scale = ${ $class . '::precision' } unless defined $scale;
478 $mode = ${ $class . '::round_mode' } unless defined $mode;
479
d5351619
T
480 if (defined $scale)
481 {
1aa3c823
JK
482 $scale = $scale->can('numify') ? $scale->numify()
483 : "$scale" if ref($scale);
d5351619
T
484 $scale = int($scale);
485 }
486
b68b7ab1 487 ($scale,$mode);
58cde26e
JH
488 }
489
490##############################################################################
491# constructors
492
493sub copy
494 {
86f0d17a 495 # if two arguments, the first one is the class to "swallow" subclasses
58cde26e
JH
496 if (@_ > 1)
497 {
86f0d17a
T
498 my $self = bless {
499 sign => $_[1]->{sign},
500 value => $CALC->_copy($_[1]->{value}),
501 }, $_[0] if @_ > 1;
502
503 $self->{_a} = $_[1]->{_a} if defined $_[1]->{_a};
504 $self->{_p} = $_[1]->{_p} if defined $_[1]->{_p};
505 return $self;
58cde26e 506 }
58cde26e 507
86f0d17a
T
508 my $self = bless {
509 sign => $_[0]->{sign},
510 value => $CALC->_copy($_[0]->{value}),
511 }, ref($_[0]);
9b924220 512
86f0d17a
T
513 $self->{_a} = $_[0]->{_a} if defined $_[0]->{_a};
514 $self->{_p} = $_[0]->{_p} if defined $_[0]->{_p};
58cde26e
JH
515 $self;
516 }
517
518sub new
519 {
b22b3e31 520 # create a new BigInt object from a string or another BigInt object.
0716bf9b 521 # see hash keys documented at top
58cde26e
JH
522
523 # the argument could be an object, so avoid ||, && etc on it, this would
b22b3e31
PN
524 # cause costly overloaded code to be called. The only allowed ops are
525 # ref() and defined.
58cde26e 526
61f5c3f5 527 my ($class,$wanted,$a,$p,$r) = @_;
1aa3c823 528
61f5c3f5
T
529 # avoid numify-calls by not using || on $wanted!
530 return $class->bzero($a,$p) if !defined $wanted; # default to 0
9393ace2
JH
531 return $class->copy($wanted,$a,$p,$r)
532 if ref($wanted) && $wanted->isa($class); # MBI or subclass
58cde26e 533
61f5c3f5 534 $class->import() if $IMPORT == 0; # make require work
1aa3c823 535
9393ace2
JH
536 my $self = bless {}, $class;
537
538 # shortcut for "normal" numbers
739c8b3a 539 if ((!ref $wanted) && ($wanted =~ /^([+-]?)[1-9][0-9]*\z/))
9393ace2
JH
540 {
541 $self->{sign} = $1 || '+';
9b924220 542
9393ace2
JH
543 if ($wanted =~ /^[+-]/)
544 {
56d9de68 545 # remove sign without touching wanted to make it work with constants
9b924220
RGS
546 my $t = $wanted; $t =~ s/^[+-]//;
547 $self->{value} = $CALC->_new($t);
548 }
549 else
550 {
551 $self->{value} = $CALC->_new($wanted);
9393ace2 552 }
9393ace2
JH
553 no strict 'refs';
554 if ( (defined $a) || (defined $p)
555 || (defined ${"${class}::precision"})
556 || (defined ${"${class}::accuracy"})
557 )
558 {
559 $self->round($a,$p,$r) unless (@_ == 4 && !defined $a && !defined $p);
560 }
561 return $self;
562 }
563
58cde26e 564 # handle '+inf', '-inf' first
233f7bc0 565 if ($wanted =~ /^[+-]?inf\z/)
58cde26e 566 {
233f7bc0
T
567 $self->{sign} = $wanted; # set a default sign for bstr()
568 return $self->binf($wanted);
58cde26e
JH
569 }
570 # split str in m mantissa, e exponent, i integer, f fraction, v value, s sign
9b924220 571 my ($mis,$miv,$mfv,$es,$ev) = _split($wanted);
58cde26e
JH
572 if (!ref $mis)
573 {
990fb837
RGS
574 if ($_trap_nan)
575 {
576 require Carp; Carp::croak("$wanted is not a number in $class");
577 }
0716bf9b 578 $self->{value} = $CALC->_zero();
58cde26e
JH
579 $self->{sign} = $nan;
580 return $self;
581 }
574bacfe
JH
582 if (!ref $miv)
583 {
584 # _from_hex or _from_bin
585 $self->{value} = $mis->{value};
586 $self->{sign} = $mis->{sign};
587 return $self; # throw away $mis
588 }
58cde26e
JH
589 # make integer from mantissa by adjusting exp, then convert to bigint
590 $self->{sign} = $$mis; # store sign
0716bf9b 591 $self->{value} = $CALC->_zero(); # for all the NaN cases
58cde26e
JH
592 my $e = int("$$es$$ev"); # exponent (avoid recursion)
593 if ($e > 0)
594 {
595 my $diff = $e - CORE::length($$mfv);
596 if ($diff < 0) # Not integer
597 {
990fb837
RGS
598 if ($_trap_nan)
599 {
600 require Carp; Carp::croak("$wanted not an integer in $class");
601 }
58cde26e 602 #print "NOI 1\n";
b3abae2a 603 return $upgrade->new($wanted,$a,$p,$r) if defined $upgrade;
58cde26e
JH
604 $self->{sign} = $nan;
605 }
606 else # diff >= 0
607 {
608 # adjust fraction and add it to value
990fb837 609 #print "diff > 0 $$miv\n";
58cde26e
JH
610 $$miv = $$miv . ($$mfv . '0' x $diff);
611 }
612 }
613 else
614 {
615 if ($$mfv ne '') # e <= 0
616 {
617 # fraction and negative/zero E => NOI
990fb837
RGS
618 if ($_trap_nan)
619 {
620 require Carp; Carp::croak("$wanted not an integer in $class");
621 }
58cde26e 622 #print "NOI 2 \$\$mfv '$$mfv'\n";
b3abae2a 623 return $upgrade->new($wanted,$a,$p,$r) if defined $upgrade;
58cde26e
JH
624 $self->{sign} = $nan;
625 }
626 elsif ($e < 0)
627 {
628 # xE-y, and empty mfv
8db29734
PJA
629 # Split the mantissa at the decimal point. E.g., if
630 # $$miv = 12345 and $e = -2, then $frac = 45 and $$miv = 123.
631
632 my $frac = substr($$miv, $e); # $frac is fraction part
633 substr($$miv, $e) = ""; # $$miv is now integer part
634
635 if ($frac =~ /[^0]/)
58cde26e 636 {
990fb837
RGS
637 if ($_trap_nan)
638 {
639 require Carp; Carp::croak("$wanted not an integer in $class");
640 }
58cde26e 641 #print "NOI 3\n";
b3abae2a 642 return $upgrade->new($wanted,$a,$p,$r) if defined $upgrade;
58cde26e
JH
643 $self->{sign} = $nan;
644 }
645 }
646 }
8db29734
PJA
647 unless ($self->{sign} eq $nan) {
648 $self->{sign} = '+' if $$miv eq '0'; # normalize -0 => +0
649 $self->{value} = $CALC->_new($$miv) if $self->{sign} =~ /^[+-]$/;
650 }
0716bf9b 651 # if any of the globals is set, use them to round and store them inside $self
61f5c3f5
T
652 # do not round for new($x,undef,undef) since that is used by MBF to signal
653 # no rounding
654 $self->round($a,$p,$r) unless @_ == 4 && !defined $a && !defined $p;
9393ace2 655 $self;
58cde26e
JH
656 }
657
58cde26e
JH
658sub bnan
659 {
660 # create a bigint 'NaN', if given a BigInt, set it to 'NaN'
b4f14daa 661 my $self = shift;
58cde26e
JH
662 $self = $class if !defined $self;
663 if (!ref($self))
664 {
665 my $c = $self; $self = {}; bless $self, $c;
666 }
990fb837
RGS
667 no strict 'refs';
668 if (${"${class}::_trap_nan"})
669 {
670 require Carp;
671 Carp::croak ("Tried to set $self to NaN in $class\::bnan()");
672 }
61f5c3f5 673 $self->import() if $IMPORT == 0; # make require work
58cde26e 674 return if $self->modify('bnan');
13a12e00
JH
675 if ($self->can('_bnan'))
676 {
677 # use subclass to initialize
678 $self->_bnan();
679 }
680 else
681 {
682 # otherwise do our own thing
683 $self->{value} = $CALC->_zero();
684 }
58cde26e 685 $self->{sign} = $nan;
394e6ffb 686 delete $self->{_a}; delete $self->{_p}; # rounding NaN is silly
ef9466ea 687 $self;
b4f14daa 688 }
58cde26e
JH
689
690sub binf
691 {
692 # create a bigint '+-inf', if given a BigInt, set it to '+-inf'
693 # the sign is either '+', or if given, used from there
694 my $self = shift;
56b9c951 695 my $sign = shift; $sign = '+' if !defined $sign || $sign !~ /^-(inf)?$/;
58cde26e
JH
696 $self = $class if !defined $self;
697 if (!ref($self))
698 {
699 my $c = $self; $self = {}; bless $self, $c;
700 }
990fb837
RGS
701 no strict 'refs';
702 if (${"${class}::_trap_inf"})
703 {
704 require Carp;
233f7bc0 705 Carp::croak ("Tried to set $self to +-inf in $class\::binf()");
990fb837 706 }
61f5c3f5 707 $self->import() if $IMPORT == 0; # make require work
58cde26e 708 return if $self->modify('binf');
13a12e00
JH
709 if ($self->can('_binf'))
710 {
711 # use subclass to initialize
712 $self->_binf();
713 }
714 else
715 {
716 # otherwise do our own thing
717 $self->{value} = $CALC->_zero();
718 }
56b9c951
JH
719 $sign = $sign . 'inf' if $sign !~ /inf$/; # - => -inf
720 $self->{sign} = $sign;
394e6ffb 721 ($self->{_a},$self->{_p}) = @_; # take over requested rounding
ef9466ea 722 $self;
58cde26e
JH
723 }
724
725sub bzero
726 {
727 # create a bigint '+0', if given a BigInt, set it to 0
728 my $self = shift;
12fc2493 729 $self = __PACKAGE__ if !defined $self;
1aa3c823 730
58cde26e
JH
731 if (!ref($self))
732 {
733 my $c = $self; $self = {}; bless $self, $c;
734 }
61f5c3f5 735 $self->import() if $IMPORT == 0; # make require work
58cde26e 736 return if $self->modify('bzero');
1aa3c823 737
13a12e00
JH
738 if ($self->can('_bzero'))
739 {
740 # use subclass to initialize
741 $self->_bzero();
742 }
743 else
744 {
745 # otherwise do our own thing
746 $self->{value} = $CALC->_zero();
747 }
58cde26e 748 $self->{sign} = '+';
61f5c3f5
T
749 if (@_ > 0)
750 {
f9a08e12
JH
751 if (@_ > 3)
752 {
753 # call like: $x->bzero($a,$p,$r,$y);
754 ($self,$self->{_a},$self->{_p}) = $self->_find_round_parameters(@_);
755 }
756 else
757 {
758 $self->{_a} = $_[0]
759 if ( (!defined $self->{_a}) || (defined $_[0] && $_[0] > $self->{_a}));
760 $self->{_p} = $_[1]
761 if ( (!defined $self->{_p}) || (defined $_[1] && $_[1] > $self->{_p}));
762 }
61f5c3f5 763 }
f9a08e12 764 $self;
58cde26e
JH
765 }
766
574bacfe
JH
767sub bone
768 {
769 # create a bigint '+1' (or -1 if given sign '-'),
3c4b39be 770 # if given a BigInt, set it to +1 or -1, respectively
574bacfe
JH
771 my $self = shift;
772 my $sign = shift; $sign = '+' if !defined $sign || $sign ne '-';
773 $self = $class if !defined $self;
990fb837 774
574bacfe
JH
775 if (!ref($self))
776 {
777 my $c = $self; $self = {}; bless $self, $c;
778 }
61f5c3f5 779 $self->import() if $IMPORT == 0; # make require work
574bacfe 780 return if $self->modify('bone');
13a12e00
JH
781
782 if ($self->can('_bone'))
783 {
784 # use subclass to initialize
785 $self->_bone();
786 }
787 else
788 {
789 # otherwise do our own thing
790 $self->{value} = $CALC->_one();
791 }
574bacfe 792 $self->{sign} = $sign;
61f5c3f5
T
793 if (@_ > 0)
794 {
f9a08e12
JH
795 if (@_ > 3)
796 {
797 # call like: $x->bone($sign,$a,$p,$r,$y);
798 ($self,$self->{_a},$self->{_p}) = $self->_find_round_parameters(@_);
799 }
800 else
801 {
091c87b1 802 # call like: $x->bone($sign,$a,$p,$r);
f9a08e12
JH
803 $self->{_a} = $_[0]
804 if ( (!defined $self->{_a}) || (defined $_[0] && $_[0] > $self->{_a}));
805 $self->{_p} = $_[1]
806 if ( (!defined $self->{_p}) || (defined $_[1] && $_[1] > $self->{_p}));
807 }
61f5c3f5 808 }
f9a08e12 809 $self;
574bacfe
JH
810 }
811
58cde26e 812##############################################################################
9681bfa6 813# string conversion
58cde26e
JH
814
815sub bsstr
816 {
817 # (ref to BFLOAT or num_str ) return num_str
818 # Convert number from internal format to scientific string format.
819 # internal format is always normalized (no leading zeros, "-0E0" => "+0E0")
b68b7ab1 820 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
58cde26e 821
574bacfe
JH
822 if ($x->{sign} !~ /^[+-]$/)
823 {
824 return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN
825 return 'inf'; # +inf
826 }
58cde26e 827 my ($m,$e) = $x->parts();
b282a552
T
828 #$m->bstr() . 'e+' . $e->bstr(); # e can only be positive in BigInt
829 # 'e+' because E can only be positive in BigInt
9b924220 830 $m->bstr() . 'e+' . $CALC->_str($e->{value});
58cde26e
JH
831 }
832
833sub bstr
834 {
0716bf9b 835 # make a string from bigint object
b68b7ab1 836 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
56b9c951 837
574bacfe
JH
838 if ($x->{sign} !~ /^[+-]$/)
839 {
840 return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN
841 return 'inf'; # +inf
842 }
0716bf9b 843 my $es = ''; $es = $x->{sign} if $x->{sign} eq '-';
9b924220 844 $es.$CALC->_str($x->{value});
58cde26e
JH
845 }
846
847sub numify
848 {
394e6ffb 849 # Make a "normal" scalar from a BigInt object
58cde26e 850 my $x = shift; $x = $class->new($x) unless ref $x;
56d9de68
T
851
852 return $x->bstr() if $x->{sign} !~ /^[+-]$/;
0716bf9b
JH
853 my $num = $CALC->_num($x->{value});
854 return -$num if $x->{sign} eq '-';
9393ace2 855 $num;
58cde26e
JH
856 }
857
858##############################################################################
859# public stuff (usually prefixed with "b")
860
861sub sign
862 {
9393ace2 863 # return the sign of the number: +/-/-inf/+inf/NaN
b282a552 864 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
1aa3c823 865
9393ace2 866 $x->{sign};
58cde26e
JH
867 }
868
ee15d750 869sub _find_round_parameters
58cde26e
JH
870 {
871 # After any operation or when calling round(), the result is rounded by
872 # regarding the A & P from arguments, local parameters, or globals.
61f5c3f5 873
990fb837
RGS
874 # !!!!!!! If you change this, remember to change round(), too! !!!!!!!!!!
875
61f5c3f5
T
876 # This procedure finds the round parameters, but it is for speed reasons
877 # duplicated in round. Otherwise, it is tested by the testsuite and used
878 # by fdiv().
1aa3c823 879
990fb837
RGS
880 # returns ($self) or ($self,$a,$p,$r) - sets $self to NaN of both A and P
881 # were requested/defined (locally or globally or both)
1aa3c823 882
394e6ffb
JH
883 my ($self,$a,$p,$r,@args) = @_;
884 # $a accuracy, if given by caller
885 # $p precision, if given by caller
886 # $r round_mode, if given by caller
887 # @args all 'other' arguments (0 for unary, 1 for binary ops)
58cde26e 888
394e6ffb 889 my $c = ref($self); # find out class of argument(s)
574bacfe 890 no strict 'refs';
574bacfe 891
86b76201 892 # convert to normal scalar for speed and correctness in inner parts
86f0d17a
T
893 $a = $a->can('numify') ? $a->numify() : "$a" if defined $a && ref($a);
894 $p = $p->can('numify') ? $p->numify() : "$p" if defined $p && ref($p);
86b76201 895
58cde26e 896 # now pick $a or $p, but only if we have got "arguments"
61f5c3f5 897 if (!defined $a)
58cde26e 898 {
61f5c3f5 899 foreach ($self,@args)
58cde26e
JH
900 {
901 # take the defined one, or if both defined, the one that is smaller
902 $a = $_->{_a} if (defined $_->{_a}) && (!defined $a || $_->{_a} < $a);
903 }
61f5c3f5
T
904 }
905 if (!defined $p)
ee15d750 906 {
61f5c3f5
T
907 # even if $a is defined, take $p, to signal error for both defined
908 foreach ($self,@args)
909 {
910 # take the defined one, or if both defined, the one that is bigger
911 # -2 > -3, and 3 > 2
912 $p = $_->{_p} if (defined $_->{_p}) && (!defined $p || $_->{_p} > $p);
913 }
ee15d750 914 }
61f5c3f5
T
915 # if still none defined, use globals (#2)
916 $a = ${"$c\::accuracy"} unless defined $a;
917 $p = ${"$c\::precision"} unless defined $p;
990fb837
RGS
918
919 # A == 0 is useless, so undef it to signal no rounding
920 $a = undef if defined $a && $a == 0;
1aa3c823 921
61f5c3f5
T
922 # no rounding today?
923 return ($self) unless defined $a || defined $p; # early out
924
925 # set A and set P is an fatal error
990fb837 926 return ($self->bnan()) if defined $a && defined $p; # error
61f5c3f5
T
927
928 $r = ${"$c\::round_mode"} unless defined $r;
7b29e1e6 929 if ($r !~ /^(even|odd|\+inf|\-inf|zero|trunc|common)$/)
990fb837
RGS
930 {
931 require Carp; Carp::croak ("Unknown round mode '$r'");
932 }
933
d5351619
T
934 $a = int($a) if defined $a;
935 $p = int($p) if defined $p;
936
990fb837 937 ($self,$a,$p,$r);
ee15d750
JH
938 }
939
940sub round
941 {
61f5c3f5 942 # Round $self according to given parameters, or given second argument's
ee15d750 943 # parameters or global defaults
ee15d750 944
c4a6f826 945 # for speed reasons, _find_round_parameters is embedded here:
61f5c3f5
T
946
947 my ($self,$a,$p,$r,@args) = @_;
948 # $a accuracy, if given by caller
949 # $p precision, if given by caller
950 # $r round_mode, if given by caller
951 # @args all 'other' arguments (0 for unary, 1 for binary ops)
952
61f5c3f5
T
953 my $c = ref($self); # find out class of argument(s)
954 no strict 'refs';
955
956 # now pick $a or $p, but only if we have got "arguments"
957 if (!defined $a)
58cde26e 958 {
61f5c3f5
T
959 foreach ($self,@args)
960 {
961 # take the defined one, or if both defined, the one that is smaller
962 $a = $_->{_a} if (defined $_->{_a}) && (!defined $a || $_->{_a} < $a);
963 }
58cde26e 964 }
61f5c3f5
T
965 if (!defined $p)
966 {
967 # even if $a is defined, take $p, to signal error for both defined
968 foreach ($self,@args)
969 {
970 # take the defined one, or if both defined, the one that is bigger
971 # -2 > -3, and 3 > 2
972 $p = $_->{_p} if (defined $_->{_p}) && (!defined $p || $_->{_p} > $p);
973 }
974 }
975 # if still none defined, use globals (#2)
976 $a = ${"$c\::accuracy"} unless defined $a;
977 $p = ${"$c\::precision"} unless defined $p;
1aa3c823 978
990fb837
RGS
979 # A == 0 is useless, so undef it to signal no rounding
980 $a = undef if defined $a && $a == 0;
1aa3c823 981
61f5c3f5
T
982 # no rounding today?
983 return $self unless defined $a || defined $p; # early out
984
985 # set A and set P is an fatal error
986 return $self->bnan() if defined $a && defined $p;
987
988 $r = ${"$c\::round_mode"} unless defined $r;
7b29e1e6 989 if ($r !~ /^(even|odd|\+inf|\-inf|zero|trunc|common)$/)
990fb837 990 {
b282a552 991 require Carp; Carp::croak ("Unknown round mode '$r'");
990fb837 992 }
61f5c3f5
T
993
994 # now round, by calling either fround or ffround:
995 if (defined $a)
996 {
d5351619 997 $self->bround(int($a),$r) if !defined $self->{_a} || $self->{_a} >= $a;
61f5c3f5
T
998 }
999 else # both can't be undefined due to early out
58cde26e 1000 {
d5351619 1001 $self->bfround(int($p),$r) if !defined $self->{_p} || $self->{_p} <= $p;
58cde26e 1002 }
c4a6f826 1003 # bround() or bfround() already called bnorm() if nec.
12fc2493 1004 $self;
58cde26e
JH
1005 }
1006
17baacb7 1007sub bnorm
58cde26e 1008 {
027dc388 1009 # (numstr or BINT) return BINT
58cde26e 1010 # Normalize number -- no-op here
b282a552 1011 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
b3abae2a 1012 $x;
58cde26e
JH
1013 }
1014
1015sub babs
1016 {
1017 # (BINT or num_str) return BINT
1018 # make number absolute, or return absolute BINT from string
b68b7ab1 1019 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
ee15d750 1020
58cde26e
JH
1021 return $x if $x->modify('babs');
1022 # post-normalized abs for internal use (does nothing for NaN)
1023 $x->{sign} =~ s/^-/+/;
1024 $x;
1025 }
1026
7833bfdd
PJA
1027sub bsgn {
1028 # Signum function.
1029
1030 my $self = shift;
1031
1032 return $self if $self->modify('bsgn');
1033
1034 return $self -> bone("+") if $self -> is_pos();
1035 return $self -> bone("-") if $self -> is_neg();
1036 return $self; # zero or NaN
1037}
1038
58cde26e
JH
1039sub bneg
1040 {
1041 # (BINT or num_str) return BINT
1042 # negate number or make a negated number from string
b68b7ab1 1043 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
1aa3c823 1044
58cde26e 1045 return $x if $x->modify('bneg');
b3abae2a 1046
ada8209b 1047 # for +0 do not negate (to have always normalized +0). Does nothing for 'NaN'
b68b7ab1 1048 $x->{sign} =~ tr/+-/-+/ unless ($x->{sign} eq '+' && $CALC->_is_zero($x->{value}));
58cde26e
JH
1049 $x;
1050 }
1051
1052sub bcmp
1053 {
1054 # Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort)
1055 # (BINT or num_str, BINT or num_str) return cond_code
1aa3c823 1056
f9a08e12
JH
1057 # set up parameters
1058 my ($self,$x,$y) = (ref($_[0]),@_);
1059
1060 # objectify is costly, so avoid it
1061 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1062 {
1063 ($self,$x,$y) = objectify(2,@_);
1064 }
0716bf9b 1065
56d9de68
T
1066 return $upgrade->bcmp($x,$y) if defined $upgrade &&
1067 ((!$x->isa($self)) || (!$y->isa($self)));
1068
0716bf9b
JH
1069 if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
1070 {
1071 # handle +-inf and NaN
1072 return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
574bacfe 1073 return 0 if $x->{sign} eq $y->{sign} && $x->{sign} =~ /^[+-]inf$/;
0716bf9b
JH
1074 return +1 if $x->{sign} eq '+inf';
1075 return -1 if $x->{sign} eq '-inf';
1076 return -1 if $y->{sign} eq '+inf';
b3abae2a 1077 return +1;
0716bf9b 1078 }
574bacfe
JH
1079 # check sign for speed first
1080 return 1 if $x->{sign} eq '+' && $y->{sign} eq '-'; # does also 0 <=> -y
1081 return -1 if $x->{sign} eq '-' && $y->{sign} eq '+'; # does also -x <=> 0
1082
1aa3c823
JK
1083 # have same sign, so compare absolute values. Don't make tests for zero
1084 # here because it's actually slower than testing in Calc (especially w/ Pari
1085 # et al)
f9a08e12 1086
dccbb853
JH
1087 # post-normalized compare for internal use (honors signs)
1088 if ($x->{sign} eq '+')
1089 {
56b9c951 1090 # $x and $y both > 0
dccbb853
JH
1091 return $CALC->_acmp($x->{value},$y->{value});
1092 }
1093
56b9c951 1094 # $x && $y both < 0
ada8209b 1095 $CALC->_acmp($y->{value},$x->{value}); # swapped acmp (lib returns 0,1,-1)
58cde26e
JH
1096 }
1097
1098sub bacmp
1099 {
1100 # Compares 2 values, ignoring their signs.
1101 # Returns one of undef, <0, =0, >0. (suitable for sort)
1102 # (BINT, BINT) return cond_code
1aa3c823 1103
f9a08e12
JH
1104 # set up parameters
1105 my ($self,$x,$y) = (ref($_[0]),@_);
1106 # objectify is costly, so avoid it
1107 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1108 {
1109 ($self,$x,$y) = objectify(2,@_);
1110 }
1111
56d9de68
T
1112 return $upgrade->bacmp($x,$y) if defined $upgrade &&
1113 ((!$x->isa($self)) || (!$y->isa($self)));
1114
574bacfe
JH
1115 if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
1116 {
1117 # handle +-inf and NaN
1118 return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
1119 return 0 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} =~ /^[+-]inf$/;
ef9466ea
T
1120 return 1 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} !~ /^[+-]inf$/;
1121 return -1;
574bacfe 1122 }
b3abae2a 1123 $CALC->_acmp($x->{value},$y->{value}); # lib does only 0,1,-1
58cde26e
JH
1124 }
1125
1126sub badd
1127 {
1128 # add second arg (BINT or string) to first (BINT) (modifies first)
1129 # return result as BINT
f9a08e12
JH
1130
1131 # set up parameters
1132 my ($self,$x,$y,@r) = (ref($_[0]),@_);
1133 # objectify is costly, so avoid it
1134 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1135 {
1136 ($self,$x,$y,@r) = objectify(2,@_);
1137 }
58cde26e
JH
1138
1139 return $x if $x->modify('badd');
091c87b1 1140 return $upgrade->badd($upgrade->new($x),$upgrade->new($y),@r) if defined $upgrade &&
8f675a64 1141 ((!$x->isa($self)) || (!$y->isa($self)));
58cde26e 1142
61f5c3f5 1143 $r[3] = $y; # no push!
574bacfe
JH
1144 # inf and NaN handling
1145 if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
1146 {
1147 # NaN first
1148 return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
13a12e00
JH
1149 # inf handling
1150 if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/))
574bacfe 1151 {
b3abae2a
JH
1152 # +inf++inf or -inf+-inf => same, rest is NaN
1153 return $x if $x->{sign} eq $y->{sign};
1154 return $x->bnan();
574bacfe
JH
1155 }
1156 # +-inf + something => +inf
1157 # something +-inf => +-inf
1158 $x->{sign} = $y->{sign}, return $x if $y->{sign} =~ /^[+-]inf$/;
1159 return $x;
1160 }
1aa3c823 1161
b282a552 1162 my ($sx, $sy) = ( $x->{sign}, $y->{sign} ); # get signs
58cde26e
JH
1163
1164 if ($sx eq $sy)
1165 {
574bacfe 1166 $x->{value} = $CALC->_add($x->{value},$y->{value}); # same sign, abs add
58cde26e
JH
1167 }
1168 else
1169 {
574bacfe 1170 my $a = $CALC->_acmp ($y->{value},$x->{value}); # absolute compare
58cde26e
JH
1171 if ($a > 0)
1172 {
574bacfe 1173 $x->{value} = $CALC->_sub($y->{value},$x->{value},1); # abs sub w/ swap
58cde26e
JH
1174 $x->{sign} = $sy;
1175 }
1176 elsif ($a == 0)
1177 {
1178 # speedup, if equal, set result to 0
0716bf9b 1179 $x->{value} = $CALC->_zero();
58cde26e
JH
1180 $x->{sign} = '+';
1181 }
1182 else # a < 0
1183 {
574bacfe 1184 $x->{value} = $CALC->_sub($x->{value}, $y->{value}); # abs sub
a0d0e21e 1185 }
a0d0e21e 1186 }
b68b7ab1 1187 $x->round(@r);
58cde26e
JH
1188 }
1189
1190sub bsub
1191 {
091c87b1 1192 # (BINT or num_str, BINT or num_str) return BINT
58cde26e 1193 # subtract second arg from first, modify first
1aa3c823 1194
f9a08e12
JH
1195 # set up parameters
1196 my ($self,$x,$y,@r) = (ref($_[0]),@_);
7d193e39 1197
f9a08e12
JH
1198 # objectify is costly, so avoid it
1199 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1200 {
1201 ($self,$x,$y,@r) = objectify(2,@_);
1202 }
58cde26e 1203
58cde26e 1204 return $x if $x->modify('bsub');
8f675a64 1205
9b924220
RGS
1206 return $upgrade->new($x)->bsub($upgrade->new($y),@r) if defined $upgrade &&
1207 ((!$x->isa($self)) || (!$y->isa($self)));
b3abae2a 1208
b68b7ab1 1209 return $x->round(@r) if $y->is_zero();
b3abae2a 1210
a87115f0
RGS
1211 # To correctly handle the lone special case $x->bsub($x), we note the sign
1212 # of $x, then flip the sign from $y, and if the sign of $x did change, too,
1213 # then we caught the special case:
1214 my $xsign = $x->{sign};
1215 $y->{sign} =~ tr/+\-/-+/; # does nothing for NaN
1216 if ($xsign ne $x->{sign})
03874afe 1217 {
a87115f0
RGS
1218 # special case of $x->bsub($x) results in 0
1219 return $x->bzero(@r) if $xsign =~ /^[+-]$/;
03874afe
T
1220 return $x->bnan(); # NaN, -inf, +inf
1221 }
b3abae2a
JH
1222 $x->badd($y,@r); # badd does not leave internal zeros
1223 $y->{sign} =~ tr/+\-/-+/; # refix $y (does nothing for NaN)
7b29e1e6 1224 $x; # already rounded by badd() or no round nec.
58cde26e
JH
1225 }
1226
1227sub binc
1228 {
1229 # increment arg by one
ee15d750 1230 my ($self,$x,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
58cde26e 1231 return $x if $x->modify('binc');
e745a66c
JH
1232
1233 if ($x->{sign} eq '+')
1234 {
1235 $x->{value} = $CALC->_inc($x->{value});
b68b7ab1 1236 return $x->round($a,$p,$r);
e745a66c
JH
1237 }
1238 elsif ($x->{sign} eq '-')
1239 {
1240 $x->{value} = $CALC->_dec($x->{value});
1241 $x->{sign} = '+' if $CALC->_is_zero($x->{value}); # -1 +1 => -0 => +0
b68b7ab1 1242 return $x->round($a,$p,$r);
e745a66c
JH
1243 }
1244 # inf, nan handling etc
091c87b1 1245 $x->badd($self->bone(),$a,$p,$r); # badd does round
58cde26e
JH
1246 }
1247
1248sub bdec
1249 {
1250 # decrement arg by one
b282a552 1251 my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
58cde26e 1252 return $x if $x->modify('bdec');
1aa3c823 1253
b282a552 1254 if ($x->{sign} eq '-')
e745a66c 1255 {
b68b7ab1 1256 # x already < 0
e745a66c 1257 $x->{value} = $CALC->_inc($x->{value});
b282a552
T
1258 }
1259 else
e745a66c 1260 {
1aa3c823
JK
1261 return $x->badd($self->bone('-'),@r)
1262 unless $x->{sign} eq '+'; # inf or NaN
b282a552
T
1263 # >= 0
1264 if ($CALC->_is_zero($x->{value}))
1265 {
1266 # == 0
1267 $x->{value} = $CALC->_one(); $x->{sign} = '-'; # 0 => -1
1268 }
1269 else
1270 {
1271 # > 0
1272 $x->{value} = $CALC->_dec($x->{value});
1273 }
e745a66c 1274 }
b68b7ab1 1275 $x->round(@r);
b282a552 1276 }
58cde26e 1277
61f5c3f5
T
1278sub blog
1279 {
06ce15ad
SH
1280 # Return the logarithm of the operand. If a second operand is defined, that
1281 # value is used as the base, otherwise the base is assumed to be Euler's
1282 # constant.
1283
1284 # Don't objectify the base, since an undefined base, as in $x->blog() or
1285 # $x->blog(undef) signals that the base is Euler's number.
091c87b1
T
1286
1287 # set up parameters
b68b7ab1 1288 my ($self,$x,$base,@r) = (undef,@_);
091c87b1 1289 # objectify is costly, so avoid it
06ce15ad
SH
1290 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
1291 ($self,$x,$base,@r) = objectify(1,@_);
1292 }
a0ac753d 1293
ef9466ea
T
1294 return $x if $x->modify('blog');
1295
06ce15ad
SH
1296 # Handle all exception cases and all trivial cases. I have used Wolfram Alpha
1297 # (http://www.wolframalpha.com) as the reference for these cases.
1298
1299 return $x -> bnan() if $x -> is_nan();
1300
1301 if (defined $base) {
1302 $base = $self -> new($base) unless ref $base;
1303 if ($base -> is_nan() || $base -> is_one()) {
1304 return $x -> bnan();
1305 } elsif ($base -> is_inf() || $base -> is_zero()) {
1306 return $x -> bnan() if $x -> is_inf() || $x -> is_zero();
1307 return $x -> bzero();
1308 } elsif ($base -> is_negative()) { # -inf < base < 0
1309 return $x -> bzero() if $x -> is_one(); # x = 1
1310 return $x -> bone() if $x == $base; # x = base
1311 return $x -> bnan(); # otherwise
1312 }
1313 return $x -> bone() if $x == $base; # 0 < base && 0 < x < inf
1314 }
2ebb273f 1315
06ce15ad 1316 # We now know that the base is either undefined or >= 2 and finite.
091c87b1 1317
06ce15ad
SH
1318 return $x -> binf('+') if $x -> is_inf(); # x = +/-inf
1319 return $x -> bnan() if $x -> is_neg(); # -inf < x < 0
1320 return $x -> bzero() if $x -> is_one(); # x = 1
1321 return $x -> binf('-') if $x -> is_zero(); # x = 0
1322
1323 # At this point we are done handling all exception cases and trivial cases.
1324
1325 return $upgrade -> blog($upgrade -> new($x), $base, @r) if defined $upgrade;
091c87b1 1326
a0ac753d
T
1327 # fix for bug #24969:
1328 # the default base is e (Euler's number) which is not an integer
1329 if (!defined $base)
1330 {
1331 require Math::BigFloat;
1332 my $u = Math::BigFloat->blog(Math::BigFloat->new($x))->as_int();
1333 # modify $x in place
1334 $x->{value} = $u->{value};
1335 $x->{sign} = $u->{sign};
1336 return $x;
1337 }
1aa3c823 1338
9b924220 1339 my ($rc,$exact) = $CALC->_log_int($x->{value},$base->{value});
06ce15ad 1340 return $x->bnan() unless defined $rc; # not possible to take log?
9b924220
RGS
1341 $x->{value} = $rc;
1342 $x->round(@r);
61f5c3f5 1343 }
091c87b1 1344
50109ad0
RGS
1345sub bnok
1346 {
1347 # Calculate n over k (binomial coefficient or "choose" function) as integer.
1348 # set up parameters
1349 my ($self,$x,$y,@r) = (ref($_[0]),@_);
1350
1351 # objectify is costly, so avoid it
1352 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1353 {
1354 ($self,$x,$y,@r) = objectify(2,@_);
1355 }
1356
1357 return $x if $x->modify('bnok');
1358 return $x->bnan() if $x->{sign} eq 'NaN' || $y->{sign} eq 'NaN';
1359 return $x->binf() if $x->{sign} eq '+inf';
1360
1361 # k > n or k < 0 => 0
1362 my $cmp = $x->bacmp($y);
1363 return $x->bzero() if $cmp < 0 || $y->{sign} =~ /^-/;
1364 # k == n => 1
1365 return $x->bone(@r) if $cmp == 0;
1366
1367 if ($CALC->can('_nok'))
1368 {
1369 $x->{value} = $CALC->_nok($x->{value},$y->{value});
1370 }
1371 else
1372 {
d5735945
PF
1373 # ( 7 ) 7! 1*2*3*4 * 5*6*7 5 * 6 * 7 6 7
1374 # ( - ) = --------- = --------------- = --------- = 5 * - * -
1375 # ( 3 ) (7-3)! 3! 1*2*3*4 * 1*2*3 1 * 2 * 3 2 3
50109ad0 1376
d5735945 1377 if (!$y->is_zero())
50109ad0 1378 {
d5735945 1379 my $z = $x - $y;
50109ad0
RGS
1380 $z->binc();
1381 my $r = $z->copy(); $z->binc();
1382 my $d = $self->new(2);
d5735945 1383 while ($z->bacmp($x) <= 0) # f <= x ?
50109ad0
RGS
1384 {
1385 $r->bmul($z); $r->bdiv($d);
1386 $z->binc(); $d->binc();
1387 }
1388 $x->{value} = $r->{value}; $x->{sign} = '+';
1389 }
1390 else { $x->bone(); }
1391 }
1392 $x->round(@r);
1393 }
1394
7d193e39
T
1395sub bexp
1396 {
1397 # Calculate e ** $x (Euler's number to the power of X), truncated to
1398 # an integer value.
1399 my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
1400 return $x if $x->modify('bexp');
1401
1402 # inf, -inf, NaN, <0 => NaN
1403 return $x->bnan() if $x->{sign} eq 'NaN';
1404 return $x->bone() if $x->is_zero();
1405 return $x if $x->{sign} eq '+inf';
1406 return $x->bzero() if $x->{sign} eq '-inf';
1407
1408 my $u;
1409 {
1410 # run through Math::BigFloat unless told otherwise
50109ad0 1411 require Math::BigFloat unless defined $upgrade;
7d193e39
T
1412 local $upgrade = 'Math::BigFloat' unless defined $upgrade;
1413 # calculate result, truncate it to integer
1414 $u = $upgrade->bexp($upgrade->new($x),@r);
1415 }
1416
1417 if (!defined $upgrade)
1418 {
1419 $u = $u->as_int();
1420 # modify $x in place
1421 $x->{value} = $u->{value};
1422 $x->round(@r);
1423 }
1424 else { $x = $u; }
1425 }
1426
fdd59300
FR
1427sub blcm
1428 {
58cde26e
JH
1429 # (BINT or num_str, BINT or num_str) return BINT
1430 # does not modify arguments, but returns new object
fdd59300 1431 # Lowest Common Multiple
58cde26e 1432
0716bf9b
JH
1433 my $y = shift; my ($x);
1434 if (ref($y))
1435 {
1436 $x = $y->copy();
1437 }
1438 else
1439 {
12fc2493 1440 $x = $class->new($y);
0716bf9b 1441 }
9b924220
RGS
1442 my $self = ref($x);
1443 while (@_)
1444 {
1445 my $y = shift; $y = $self->new($y) if !ref ($y);
1446 $x = __lcm($x,$y);
1447 }
58cde26e
JH
1448 $x;
1449 }
1450
1451sub bgcd
1452 {
1453 # (BINT or num_str, BINT or num_str) return BINT
1454 # does not modify arguments, but returns new object
c4a6f826 1455 # GCD -- Euclid's algorithm, variant C (Knuth Vol 3, pg 341 ff)
0716bf9b 1456
dccbb853 1457 my $y = shift;
12fc2493 1458 $y = $class->new($y) if !ref($y);
dccbb853 1459 my $self = ref($y);
9b924220
RGS
1460 my $x = $y->copy()->babs(); # keep arguments
1461 return $x->bnan() if $x->{sign} !~ /^[+-]$/; # x NaN?
1462
1463 while (@_)
0716bf9b 1464 {
9b924220 1465 $y = shift; $y = $self->new($y) if !ref($y);
9b924220 1466 return $x->bnan() if $y->{sign} !~ /^[+-]$/; # y NaN?
b68b7ab1
T
1467 $x->{value} = $CALC->_gcd($x->{value},$y->{value});
1468 last if $CALC->_is_one($x->{value});
0716bf9b 1469 }
9b924220 1470 $x;
58cde26e
JH
1471 }
1472
58cde26e
JH
1473sub bnot
1474 {
1475 # (num_str or BINT) return BINT
1476 # represent ~x as twos-complement number
ee15d750
JH
1477 # we don't need $self, so undef instead of ref($_[0]) make it slightly faster
1478 my ($self,$x,$a,$p,$r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
1aa3c823 1479
58cde26e 1480 return $x if $x->modify('bnot');
091c87b1 1481 $x->binc()->bneg(); # binc already does round
58cde26e
JH
1482 }
1483
091c87b1 1484##############################################################################
b3abae2a 1485# is_foo test routines
091c87b1 1486# we don't need $self, so undef instead of ref($_[0]) make it slightly faster
b3abae2a 1487
58cde26e
JH
1488sub is_zero
1489 {
1490 # return true if arg (BINT or num_str) is zero (array '+', '0')
ee15d750 1491 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
1aa3c823 1492
574bacfe 1493 return 0 if $x->{sign} !~ /^\+$/; # -, NaN & +-inf aren't
17baacb7 1494 $CALC->_is_zero($x->{value});
58cde26e
JH
1495 }
1496
1497sub is_nan
1498 {
1499 # return true if arg (BINT or num_str) is NaN
091c87b1 1500 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
ee15d750 1501
091c87b1 1502 $x->{sign} eq $nan ? 1 : 0;
58cde26e
JH
1503 }
1504
1505sub is_inf
1506 {
1507 # return true if arg (BINT or num_str) is +-inf
091c87b1 1508 my ($self,$x,$sign) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
58cde26e 1509
091c87b1 1510 if (defined $sign)
ee15d750 1511 {
091c87b1
T
1512 $sign = '[+-]inf' if $sign eq ''; # +- doesn't matter, only that's inf
1513 $sign = "[$1]inf" if $sign =~ /^([+-])(inf)?$/; # extract '+' or '-'
1514 return $x->{sign} =~ /^$sign$/ ? 1 : 0;
ee15d750 1515 }
091c87b1 1516 $x->{sign} =~ /^[+-]inf$/ ? 1 : 0; # only +-inf is infinity
58cde26e
JH
1517 }
1518
1519sub is_one
1520 {
091c87b1 1521 # return true if arg (BINT or num_str) is +1, or -1 if sign is given
ee15d750 1522 my ($self,$x,$sign) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
1aa3c823 1523
990fb837 1524 $sign = '+' if !defined $sign || $sign ne '-';
1aa3c823 1525
ee15d750 1526 return 0 if $x->{sign} ne $sign; # -1 != +1, NaN, +-inf aren't either
394e6ffb 1527 $CALC->_is_one($x->{value});
58cde26e
JH
1528 }
1529
1530sub is_odd
1531 {
1532 # return true when arg (BINT or num_str) is odd, false for even
ee15d750 1533 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
0716bf9b 1534
b22b3e31 1535 return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't
394e6ffb 1536 $CALC->_is_odd($x->{value});
58cde26e
JH
1537 }
1538
1539sub is_even
1540 {
1541 # return true when arg (BINT or num_str) is even, false for odd
ee15d750 1542 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
0716bf9b 1543
b22b3e31 1544 return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't
394e6ffb 1545 $CALC->_is_even($x->{value});
0716bf9b
JH
1546 }
1547
1548sub is_positive
1549 {
4af46cb8 1550 # return true when arg (BINT or num_str) is positive (> 0)
ee15d750 1551 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
b68b7ab1
T
1552
1553 return 1 if $x->{sign} eq '+inf'; # +inf is positive
4af46cb8 1554
b68b7ab1 1555 # 0+ is neither positive nor negative
4af46cb8 1556 ($x->{sign} eq '+' && !$x->is_zero()) ? 1 : 0;
0716bf9b
JH
1557 }
1558
1559sub is_negative
1560 {
1561 # return true when arg (BINT or num_str) is negative (< 0)
ee15d750 1562 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
1aa3c823 1563
b68b7ab1 1564 $x->{sign} =~ /^-/ ? 1 : 0; # -inf is negative, but NaN is not
58cde26e
JH
1565 }
1566
b3abae2a
JH
1567sub is_int
1568 {
1569 # return true when arg (BINT or num_str) is an integer
091c87b1 1570 # always true for BigInt, but different for BigFloats
b3abae2a 1571 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
1aa3c823 1572
b3abae2a
JH
1573 $x->{sign} =~ /^[+-]$/ ? 1 : 0; # inf/-inf/NaN aren't
1574 }
1575
0716bf9b
JH
1576###############################################################################
1577
58cde26e
JH
1578sub bmul
1579 {
c97ef841 1580 # multiply the first number by the second number
58cde26e 1581 # (BINT or num_str, BINT or num_str) return BINT
f9a08e12
JH
1582
1583 # set up parameters
1584 my ($self,$x,$y,@r) = (ref($_[0]),@_);
1585 # objectify is costly, so avoid it
1586 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1587 {
1588 ($self,$x,$y,@r) = objectify(2,@_);
1589 }
a0ac753d 1590
58cde26e 1591 return $x if $x->modify('bmul');
61f5c3f5 1592
574bacfe 1593 return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
b3abae2a 1594
574bacfe
JH
1595 # inf handling
1596 if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
1597 {
b3abae2a 1598 return $x->bnan() if $x->is_zero() || $y->is_zero();
574bacfe
JH
1599 # result will always be +-inf:
1600 # +inf * +/+inf => +inf, -inf * -/-inf => +inf
1601 # +inf * -/-inf => -inf, -inf * +/+inf => -inf
1602 return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
1603 return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
1604 return $x->binf('-');
1605 }
9b924220
RGS
1606
1607 return $upgrade->bmul($x,$upgrade->new($y),@r)
1608 if defined $upgrade && !$y->isa($self);
1aa3c823 1609
9393ace2 1610 $r[3] = $y; # no push here
58cde26e 1611
0716bf9b 1612 $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-'; # +1 * +1 or -1 * -1 => +
dccbb853 1613
b3abae2a
JH
1614 $x->{value} = $CALC->_mul($x->{value},$y->{value}); # do actual math
1615 $x->{sign} = '+' if $CALC->_is_zero($x->{value}); # no -0
f9a08e12 1616
b68b7ab1 1617 $x->round(@r);
dccbb853
JH
1618 }
1619
80365507
T
1620sub bmuladd
1621 {
1622 # multiply two numbers and then add the third to the result
1623 # (BINT or num_str, BINT or num_str, BINT or num_str) return BINT
1624
1625 # set up parameters
913a64d5 1626 my ($self,$x,$y,$z,@r) = objectify(3,@_);
80365507
T
1627
1628 return $x if $x->modify('bmuladd');
1629
1630 return $x->bnan() if ($x->{sign} eq $nan) ||
1631 ($y->{sign} eq $nan) ||
1632 ($z->{sign} eq $nan);
1633
1634 # inf handling of x and y
1635 if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
1636 {
1637 return $x->bnan() if $x->is_zero() || $y->is_zero();
1638 # result will always be +-inf:
1639 # +inf * +/+inf => +inf, -inf * -/-inf => +inf
1640 # +inf * -/-inf => -inf, -inf * +/+inf => -inf
1641 return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
1642 return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
1643 return $x->binf('-');
1644 }
1645 # inf handling x*y and z
1646 if (($z->{sign} =~ /^[+-]inf$/))
1647 {
1648 # something +-inf => +-inf
1649 $x->{sign} = $z->{sign}, return $x if $z->{sign} =~ /^[+-]inf$/;
1650 }
1651
1652 return $upgrade->bmuladd($x,$upgrade->new($y),$upgrade->new($z),@r)
1653 if defined $upgrade && (!$y->isa($self) || !$z->isa($self) || !$x->isa($self));
1aa3c823 1654
c97ef841 1655 # TODO: what if $y and $z have A or P set?
80365507
T
1656 $r[3] = $z; # no push here
1657
1658 $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-'; # +1 * +1 or -1 * -1 => +
1659
1660 $x->{value} = $CALC->_mul($x->{value},$y->{value}); # do actual math
1661 $x->{sign} = '+' if $CALC->_is_zero($x->{value}); # no -0
1662
1663 my ($sx, $sz) = ( $x->{sign}, $z->{sign} ); # get signs
1664
1665 if ($sx eq $sz)
1666 {
1667 $x->{value} = $CALC->_add($x->{value},$z->{value}); # same sign, abs add
1668 }
1669 else
1670 {
1671 my $a = $CALC->_acmp ($z->{value},$x->{value}); # absolute compare
1672 if ($a > 0)
1673 {
1674 $x->{value} = $CALC->_sub($z->{value},$x->{value},1); # abs sub w/ swap
1675 $x->{sign} = $sz;
1676 }
1677 elsif ($a == 0)
1678 {
1679 # speedup, if equal, set result to 0
1680 $x->{value} = $CALC->_zero();
1681 $x->{sign} = '+';
1682 }
1683 else # a < 0
1684 {
1685 $x->{value} = $CALC->_sub($x->{value}, $z->{value}); # abs sub
1686 }
1687 }
1688 $x->round(@r);
1689 }
1690
b4a10d33 1691sub bdiv
dccbb853 1692 {
dccbb853 1693
b4a10d33
PJA
1694 # This does floored division, where the quotient is floored toward negative
1695 # infinity and the remainder has the same sign as the divisor.
1aa3c823 1696
b4a10d33
PJA
1697 # Set up parameters.
1698 my ($self,$x,$y,@r) = (ref($_[0]),@_);
1699
1700 # objectify() is costly, so avoid it if we can.
1701 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
1702 ($self,$x,$y,@r) = objectify(2,@_);
dccbb853 1703 }
b4a10d33
PJA
1704
1705 return $x if $x->modify('bdiv');
1706
1707 my $wantarray = wantarray; # call only once
1708
1709 # At least one argument is NaN. Return NaN for both quotient and the
1710 # modulo/remainder.
1711
1712 if ($x -> is_nan() || $y -> is_nan()) {
1713 return $wantarray ? ($x -> bnan(), $self -> bnan()) : $x -> bnan();
dccbb853 1714 }
1aa3c823 1715
b4a10d33
PJA
1716 # Divide by zero and modulo zero.
1717 #
1718 # Division: Use the common convention that x / 0 is inf with the same sign
1719 # as x, except when x = 0, where we return NaN. This is also what earlier
1720 # versions did.
1721 #
1722 # Modulo: In modular arithmetic, the congruence relation z = x (mod y)
1723 # means that there is some integer k such that z - x = k y. If y = 0, we
1724 # get z - x = 0 or z = x. This is also what earlier versions did, except
1725 # that 0 % 0 returned NaN.
1726 #
1727 # inf / 0 = inf inf % 0 = inf
1728 # 5 / 0 = inf 5 % 0 = 5
1729 # 0 / 0 = NaN 0 % 0 = 0 (before: NaN)
1730 # -5 / 0 = -inf -5 % 0 = -5
1731 # -inf / 0 = -inf -inf % 0 = -inf
1732
1733 if ($y -> is_zero()) {
1734 my ($quo, $rem);
1735 if ($wantarray) {
1736 $rem = $x -> copy();
1737 }
1738 if ($x -> is_zero()) {
1739 $quo = $x -> bnan();
1740 } else {
1741 $quo = $x -> binf($x -> {sign});
1742 }
1743 return $wantarray ? ($quo, $rem) : $quo;
1744 }
1745
1746 # Numerator (dividend) is +/-inf, and denominator is finite and non-zero.
1747 # The divide by zero cases are covered above. In all of the cases listed
1748 # below we return the same as core Perl.
1749 #
1750 # inf / -inf = NaN inf % -inf = NaN
1751 # inf / -5 = -inf inf % -5 = NaN (before: 0)
1752 # inf / 5 = inf inf % 5 = NaN (before: 0)
1753 # inf / inf = NaN inf % inf = NaN
1754 #
1755 # -inf / -inf = NaN -inf % -inf = NaN
1756 # -inf / -5 = inf -inf % -5 = NaN (before: 0)
1757 # -inf / 5 = -inf -inf % 5 = NaN (before: 0)
1758 # -inf / inf = NaN -inf % inf = NaN
1759
1760 if ($x -> is_inf()) {
1761 my ($quo, $rem);
1762 $rem = $self -> bnan() if $wantarray;
1763 if ($y -> is_inf()) {
1764 $quo = $x -> bnan();
1765 } else {
1766 my $sign = $x -> bcmp(0) == $y -> bcmp(0) ? '+' : '-';
1767 $quo = $x -> binf($sign);
dccbb853 1768 }
b4a10d33 1769 return $wantarray ? ($quo, $rem) : $quo;
dccbb853 1770 }
1aa3c823 1771
b4a10d33
PJA
1772 # Denominator (divisor) is +/-inf. The cases when the numerator is +/-inf
1773 # are covered above. In the modulo cases (in the right column) we return
1774 # the same as core Perl, which does floored division, so for consistency we
1775 # also do floored division in the division cases (in the left column).
1776 #
1777 # -5 / inf = -1 (before: 0) -5 % inf = inf (before: -5)
1778 # 0 / inf = 0 0 % inf = 0
1779 # 5 / inf = 0 5 % inf = 5
1780 #
1781 # -5 / -inf = 0 -5 % -inf = -5
1782 # 0 / -inf = 0 0 % -inf = 0
1783 # 5 / -inf = -1 (before: 0) 5 % -inf = -inf (before: 5)
1784
1785 if ($y -> is_inf()) {
1786 my ($quo, $rem);
1787 if ($x -> is_zero() || $x -> bcmp(0) == $y -> bcmp(0)) {
1788 $rem = $x -> copy() if $wantarray;
1789 $quo = $x -> bzero();
1790 } else {
1791 $rem = $self -> binf($y -> {sign}) if $wantarray;
1792 $quo = $x -> bone('-');
1793 }
1794 return $wantarray ? ($quo, $rem) : $quo;
58cde26e
JH
1795 }
1796
b4a10d33
PJA
1797 # At this point, both the numerator and denominator are finite numbers, and
1798 # the denominator (divisor) is non-zero.
58cde26e 1799
9393ace2
JH
1800 return $upgrade->bdiv($upgrade->new($x),$upgrade->new($y),@r)
1801 if defined $upgrade;
1aa3c823 1802
990fb837
RGS
1803 $r[3] = $y; # no push!
1804
b4a10d33 1805 # Inialize remainder.
58cde26e 1806
394e6ffb 1807 my $rem = $self->bzero();
b4a10d33
PJA
1808
1809 # Are both operands the same object, i.e., like $x -> bdiv($x)?
1810 # If so, flipping the sign of $y also flips the sign of $x.
1811
1812 my $xsign = $x->{sign};
1813 my $ysign = $y->{sign};
1814
1815 $y->{sign} =~ tr/+-/-+/; # Flip the sign of $y, and see ...
1816 my $same = $xsign ne $x->{sign}; # ... if that changed the sign of $x.
1817 $y->{sign} = $ysign; # Re-insert the original sign.
1818
1819 if ($same) {
1820 $x -> bone();
1821 } else {
394e6ffb 1822 ($x->{value},$rem->{value}) = $CALC->_div($x->{value},$y->{value});
b4a10d33
PJA
1823
1824 if ($CALC -> _is_zero($rem->{value})) {
1825 if ($xsign eq $ysign || $CALC -> _is_zero($x->{value})) {
1826 $x->{sign} = '+';
1827 } else {
1828 $x->{sign} = '-';
1829 }
1830 } else {
1831 if ($xsign eq $ysign) {
1832 $x->{sign} = '+';
1833 } else {
1834 if ($xsign eq '+') {
1835 $x -> badd(1);
1836 } else {
1837 $x -> bsub(1);
1838 }
1839 $x->{sign} = '-';
1840 }
1841 }
1842 }
1843
b68b7ab1 1844 $x->round(@r);
b4a10d33
PJA
1845
1846 if ($wantarray) {
1847 unless ($CALC -> _is_zero($rem->{value})) {
1848 if ($xsign ne $ysign) {
1849 $rem = $y -> copy() -> babs() -> bsub($rem);
dccbb853 1850 }
b4a10d33 1851 $rem->{sign} = $ysign;
dccbb853 1852 }
b4a10d33
PJA
1853 $rem->{_a} = $x->{_a};
1854 $rem->{_p} = $x->{_p};
b68b7ab1 1855 $rem->round(@r);
990fb837 1856 return ($x,$rem);
58cde26e 1857 }
394e6ffb 1858
b4a10d33 1859 return $x;
58cde26e
JH
1860 }
1861
d614cd8b
JH
1862###############################################################################
1863# modulus functions
1864
dccbb853
JH
1865sub bmod
1866 {
1aa3c823 1867
b4a10d33
PJA
1868 # This is the remainder after floored division, where the quotient is
1869 # floored toward negative infinity and the remainder has the same sign as
1870 # the divisor.
1871
1872 # Set up parameters.
f9a08e12 1873 my ($self,$x,$y,@r) = (ref($_[0]),@_);
b4a10d33 1874
f9a08e12
JH
1875 # objectify is costly, so avoid it
1876 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1877 {
1878 ($self,$x,$y,@r) = objectify(2,@_);
1879 }
28df3e88 1880
dccbb853 1881 return $x if $x->modify('bmod');
61f5c3f5 1882 $r[3] = $y; # no push!
b4a10d33
PJA
1883
1884 # At least one argument is NaN.
1885
1886 if ($x -> is_nan() || $y -> is_nan()) {
1887 return $x -> bnan();
1888 }
1889
1890 # Modulo zero. See documentation for bdiv().
1891
1892 if ($y -> is_zero()) {
1893 return $x;
1894 }
1895
1896 # Numerator (dividend) is +/-inf.
1897
1898 if ($x -> is_inf()) {
1899 return $x -> bnan();
dccbb853
JH
1900 }
1901
b4a10d33
PJA
1902 # Denominator (divisor) is +/-inf.
1903
1904 if ($y -> is_inf()) {
1905 if ($x -> is_zero() || $x -> bcmp(0) == $y -> bcmp(0)) {
1906 return $x;
1907 } else {
1908 return $x -> binf($y -> sign());
1909 }
1910 }
1911
1912 # Calc new sign and in case $y == +/- 1, return $x.
1913
9b924220 1914 $x->{value} = $CALC->_mod($x->{value},$y->{value});
b4a10d33
PJA
1915 if ($CALC -> _is_zero($x->{value}))
1916 {
1917 $x->{sign} = '+'; # do not leave -0
1918 }
1919 else
dccbb853 1920 {
b68b7ab1
T
1921 $x->{value} = $CALC->_sub($y->{value},$x->{value},1) # $y-$x
1922 if ($x->{sign} ne $y->{sign});
9b924220 1923 $x->{sign} = $y->{sign};
dccbb853 1924 }
b4a10d33 1925
b68b7ab1 1926 $x->round(@r);
dccbb853
JH
1927 }
1928
07d34614 1929sub bmodinv
d614cd8b 1930 {
b4a10d33
PJA
1931 # Return modular multiplicative inverse:
1932 #
1933 # z is the modular inverse of x (mod y) if and only if
1934 #
1935 # x*z ≡ 1 (mod y)
1936 #
1937 # If the modulus y is larger than one, x and z are relative primes (i.e.,
1938 # their greatest common divisor is one).
487de07a
PJA
1939 #
1940 # If no modular multiplicative inverse exists, NaN is returned.
d614cd8b 1941
f9a08e12 1942 # set up parameters
b68b7ab1 1943 my ($self,$x,$y,@r) = (undef,@_);
56d9de68 1944 # objectify is costly, so avoid it
f9a08e12
JH
1945 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1946 {
1947 ($self,$x,$y,@r) = objectify(2,@_);
56d9de68 1948 }
d614cd8b 1949
f9a08e12 1950 return $x if $x->modify('bmodinv');
d614cd8b 1951
487de07a
PJA
1952 # Return NaN if one or both arguments is +inf, -inf, or nan.
1953
1954 return $x->bnan() if ($y->{sign} !~ /^[+-]$/ ||
1955 $x->{sign} !~ /^[+-]$/);
1956
1957 # Return NaN if $y is zero; 1 % 0 makes no sense.
1958
1959 return $x->bnan() if $y->is_zero();
1960
1961 # Return 0 in the trivial case. $x % 1 or $x % -1 is zero for all finite
1962 # integers $x.
1963
1964 return $x->bzero() if ($y->is_one() ||
1965 $y->is_one('-'));
1966
1967 # Return NaN if $x = 0, or $x modulo $y is zero. The only valid case when
1968 # $x = 0 is when $y = 1 or $y = -1, but that was covered above.
1969 #
1970 # Note that computing $x modulo $y here affects the value we'll feed to
1971 # $CALC->_modinv() below when $x and $y have opposite signs. E.g., if $x =
1972 # 5 and $y = 7, those two values are fed to _modinv(), but if $x = -5 and
1973 # $y = 7, the values fed to _modinv() are $x = 2 (= -5 % 7) and $y = 7.
1974 # The value if $x is affected only when $x and $y have opposite signs.
1975
1976 $x->bmod($y);
1977 return $x->bnan() if $x->is_zero();
1978
1979 # Compute the modular multiplicative inverse of the absolute values. We'll
1980 # correct for the signs of $x and $y later. Return NaN if no GCD is found.
1981
1982 ($x->{value}, $x->{sign}) = $CALC->_modinv($x->{value}, $y->{value});
1983 return $x->bnan() if !defined $x->{value};
1984
db2e1fb3 1985 # Library inconsistency workaround: _modinv() in Math::BigInt::GMP versions
1986 # <= 1.32 return undef rather than a "+" for the sign.
1987
1988 $x->{sign} = '+' unless defined $x->{sign};
1989
487de07a
PJA
1990 # When one or both arguments are negative, we have the following
1991 # relations. If x and y are positive:
1992 #
1993 # modinv(-x, -y) = -modinv(x, y)
1994 # modinv(-x, y) = y - modinv(x, y) = -modinv(x, y) (mod y)
1995 # modinv( x, -y) = modinv(x, y) - y = modinv(x, y) (mod -y)
1996
1997 # We must swap the sign of the result if the original $x is negative.
1998 # However, we must compensate for ignoring the signs when computing the
1999 # inverse modulo. The net effect is that we must swap the sign of the
2000 # result if $y is negative.
2001
2002 $x -> bneg() if $y->{sign} eq '-';
2003
2004 # Compute $x modulo $y again after correcting the sign.
2005
2006 $x -> bmod($y) if $x->{sign} ne $y->{sign};
2007
2008 return $x;
d614cd8b
JH
2009 }
2010
07d34614 2011sub bmodpow
d614cd8b 2012 {
6c29054c
PJA
2013 # Modular exponentiation. Raises a very large number to a very large exponent
2014 # in a given very large modulus quickly, thanks to binary exponentiation.
2015 # Supports negative exponents.
d614cd8b
JH
2016 my ($self,$num,$exp,$mod,@r) = objectify(3,@_);
2017
2018 return $num if $num->modify('bmodpow');
2019
116f6d6b
PJA
2020 # When the exponent 'e' is negative, use the following relation, which is
2021 # based on finding the multiplicative inverse 'd' of 'b' modulo 'm':
2022 #
2023 # b^(-e) (mod m) = d^e (mod m) where b*d = 1 (mod m)
d614cd8b 2024
116f6d6b 2025 $num->bmodinv($mod) if ($exp->{sign} eq '-');
07d34614 2026
116f6d6b
PJA
2027 # Check for valid input. All operands must be finite, and the modulus must be
2028 # non-zero.
d614cd8b 2029
116f6d6b
PJA
2030 return $num->bnan() if ($num->{sign} =~ /NaN|inf/ || # NaN, -inf, +inf
2031 $exp->{sign} =~ /NaN|inf/ || # NaN, -inf, +inf
b4a10d33
PJA
2032 $mod->{sign} =~ /NaN|inf/); # NaN, -inf, +inf
2033
2034 # Modulo zero. See documentation for Math::BigInt's bmod() method.
2035
2036 if ($mod -> is_zero()) {
2037 if ($num -> is_zero()) {
2038 return $self -> bnan();
2039 } else {
2040 return $num -> copy();
2041 }
2042 }
d614cd8b 2043
116f6d6b
PJA
2044 # Compute 'a (mod m)', ignoring the signs on 'a' and 'm'. If the resulting
2045 # value is zero, the output is also zero, regardless of the signs on 'a' and
2046 # 'm'.
2047
2048 my $value = $CALC->_modpow($num->{value}, $exp->{value}, $mod->{value});
2049 my $sign = '+';
2050
2051 # If the resulting value is non-zero, we have four special cases, depending
2052 # on the signs on 'a' and 'm'.
2053
6c29054c 2054 unless ($CALC->_is_zero($value)) {
116f6d6b
PJA
2055
2056 # There is a negative sign on 'a' (= $num**$exp) only if the number we
2057 # are exponentiating ($num) is negative and the exponent ($exp) is odd.
2058
2059 if ($num->{sign} eq '-' && $exp->is_odd()) {
2060
2061 # When both the number 'a' and the modulus 'm' have a negative sign,
2062 # use this relation:
2063 #
2064 # -a (mod -m) = -(a (mod m))
2065
2066 if ($mod->{sign} eq '-') {
2067 $sign = '-';
2068 }
2069
2070 # When only the number 'a' has a negative sign, use this relation:
2071 #
2072 # -a (mod m) = m - (a (mod m))
2073
2074 else {
2075 # Use copy of $mod since _sub() modifies the first argument.
2076 my $mod = $CALC->_copy($mod->{value});
6c29054c 2077 $value = $CALC->_sub($mod, $value);
116f6d6b
PJA
2078 $sign = '+';
2079 }
2080
2081 } else {
2082
2083 # When only the modulus 'm' has a negative sign, use this relation:
2084 #
2085 # a (mod -m) = (a (mod m)) - m
2086 # = -(m - (a (mod m)))
2087
2088 if ($mod->{sign} eq '-') {
6c29054c 2089 # Use copy of $mod since _sub() modifies the first argument.
116f6d6b 2090 my $mod = $CALC->_copy($mod->{value});
6c29054c 2091 $value = $CALC->_sub($mod, $value);
116f6d6b
PJA
2092 $sign = '-';
2093 }
2094
2095 # When neither the number 'a' nor the modulus 'm' have a negative
2096 # sign, directly return the already computed value.
2097 #
2098 # (a (mod m))
2099
2100 }
2101
2102 }
2103
2104 $num->{value} = $value;
2105 $num->{sign} = $sign;
2106
2107 return $num;
d614cd8b
JH
2108 }
2109
2110###############################################################################
2111
b3abae2a
JH
2112sub bfac
2113 {
2114 # (BINT or num_str, BINT or num_str) return BINT
091c87b1 2115 # compute factorial number from $x, modify $x in place
b68b7ab1 2116 my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
b3abae2a 2117
b68b7ab1
T
2118 return $x if $x->modify('bfac') || $x->{sign} eq '+inf'; # inf => inf
2119 return $x->bnan() if $x->{sign} ne '+'; # NaN, <0 etc => NaN
b3abae2a 2120
9b924220
RGS
2121 $x->{value} = $CALC->_fac($x->{value});
2122 $x->round(@r);
b3abae2a 2123 }
1aa3c823 2124
58cde26e
JH
2125sub bpow
2126 {
2127 # (BINT or num_str, BINT or num_str) return BINT
2128 # compute power of two numbers -- stolen from Knuth Vol 2 pg 233
2129 # modifies first argument
aef458a0 2130
f9a08e12
JH
2131 # set up parameters
2132 my ($self,$x,$y,@r) = (ref($_[0]),@_);
2133 # objectify is costly, so avoid it
2134 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
2135 {
2136 ($self,$x,$y,@r) = objectify(2,@_);
2137 }
58cde26e
JH
2138
2139 return $x if $x->modify('bpow');
9393ace2 2140
2d2b2744
T
2141 return $x->bnan() if $x->{sign} eq $nan || $y->{sign} eq $nan;
2142
2143 # inf handling
2144 if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
2145 {
2146 if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/))
2147 {
2148 # +-inf ** +-inf
2149 return $x->bnan();
2150 }
2151 # +-inf ** Y
2152 if ($x->{sign} =~ /^[+-]inf/)
2153 {
2154 # +inf ** 0 => NaN
2155 return $x->bnan() if $y->is_zero();
2156 # -inf ** -1 => 1/inf => 0
2157 return $x->bzero() if $y->is_one('-') && $x->is_negative();
2158
2159 # +inf ** Y => inf
2160 return $x if $x->{sign} eq '+inf';
2161
2162 # -inf ** Y => -inf if Y is odd
2163 return $x if $y->is_odd();
2164 return $x->babs();
2165 }
2166 # X ** +-inf
2167
2168 # 1 ** +inf => 1
2169 return $x if $x->is_one();
1aa3c823 2170
2d2b2744
T
2171 # 0 ** inf => 0
2172 return $x if $x->is_zero() && $y->{sign} =~ /^[+]/;
2173
2174 # 0 ** -inf => inf
2175 return $x->binf() if $x->is_zero();
2176
2177 # -1 ** -inf => NaN
2178 return $x->bnan() if $x->is_one('-') && $y->{sign} =~ /^[-]/;
2179
2180 # -X ** -inf => 0
2181 return $x->bzero() if $x->{sign} eq '-' && $y->{sign} =~ /^[-]/;
2182
2183 # -1 ** inf => NaN
2184 return $x->bnan() if $x->{sign} eq '-';
2185
2186 # X ** inf => inf
2187 return $x->binf() if $y->{sign} =~ /^[+]/;
2188 # X ** -inf => 0
2189 return $x->bzero();
2190 }
2191
9393ace2 2192 return $upgrade->bpow($upgrade->new($x),$y,@r)
7b29e1e6 2193 if defined $upgrade && (!$y->isa($self) || $y->{sign} eq '-');
9393ace2 2194
61f5c3f5 2195 $r[3] = $y; # no push!
b282a552
T
2196
2197 # cases 0 ** Y, X ** 0, X ** 1, 1 ** Y are handled by Calc or Emu
2198
9b924220
RGS
2199 my $new_sign = '+';
2200 $new_sign = $y->is_odd() ? '-' : '+' if ($x->{sign} ne '+');
2201
2202 # 0 ** -7 => ( 1 / (0 ** 7)) => 1 / 0 => +inf
2203 return $x->binf()
2204 if $y->{sign} eq '-' && $x->{sign} eq '+' && $CALC->_is_zero($x->{value});
574bacfe
JH
2205 # 1 ** -y => 1 / (1 ** |y|)
2206 # so do test for negative $y after above's clause
9b924220 2207 return $x->bnan() if $y->{sign} eq '-' && !$CALC->_is_one($x->{value});
027dc388 2208
9b924220
RGS
2209 $x->{value} = $CALC->_pow($x->{value},$y->{value});
2210 $x->{sign} = $new_sign;
2211 $x->{sign} = '+' if $CALC->_is_zero($y->{value});
b68b7ab1 2212 $x->round(@r);
58cde26e
JH
2213 }
2214
2215sub blsft
2216 {
2217 # (BINT or num_str, BINT or num_str) return BINT
2218 # compute x << y, base n, y >= 0
1aa3c823 2219
f9a08e12
JH
2220 # set up parameters
2221 my ($self,$x,$y,$n,@r) = (ref($_[0]),@_);
2222 # objectify is costly, so avoid it
2223 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
2224 {
2225 ($self,$x,$y,$n,@r) = objectify(2,@_);
2226 }
2227
58cde26e
JH
2228 return $x if $x->modify('blsft');
2229 return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
f9a08e12 2230 return $x->round(@r) if $y->is_zero();
58cde26e 2231
574bacfe
JH
2232 $n = 2 if !defined $n; return $x->bnan() if $n <= 0 || $y->{sign} eq '-';
2233
9b924220
RGS
2234 $x->{value} = $CALC->_lsft($x->{value},$y->{value},$n);
2235 $x->round(@r);
58cde26e
JH
2236 }
2237
2238sub brsft
2239 {
2240 # (BINT or num_str, BINT or num_str) return BINT
2241 # compute x >> y, base n, y >= 0
1aa3c823 2242
f9a08e12
JH
2243 # set up parameters
2244 my ($self,$x,$y,$n,@r) = (ref($_[0]),@_);
2245 # objectify is costly, so avoid it
2246 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
2247 {
2248 ($self,$x,$y,$n,@r) = objectify(2,@_);
2249 }
58cde26e
JH
2250
2251 return $x if $x->modify('brsft');
2252 return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
f9a08e12
JH
2253 return $x->round(@r) if $y->is_zero();
2254 return $x->bzero(@r) if $x->is_zero(); # 0 => 0
58cde26e
JH
2255
2256 $n = 2 if !defined $n; return $x->bnan() if $n <= 0 || $y->{sign} eq '-';
574bacfe 2257
b3abae2a
JH
2258 # this only works for negative numbers when shifting in base 2
2259 if (($x->{sign} eq '-') && ($n == 2))
2260 {
f9a08e12 2261 return $x->round(@r) if $x->is_one('-'); # -1 => -1
b3abae2a
JH
2262 if (!$y->is_one())
2263 {
2264 # although this is O(N*N) in calc (as_bin!) it is O(N) in Pari et al
2265 # but perhaps there is a better emulation for two's complement shift...
2266 # if $y != 1, we must simulate it by doing:
2267 # convert to bin, flip all bits, shift, and be done
2268 $x->binc(); # -3 => -2
2269 my $bin = $x->as_bin();
2270 $bin =~ s/^-0b//; # strip '-0b' prefix
2271 $bin =~ tr/10/01/; # flip bits
2272 # now shift
a0ac753d 2273 if ($y >= CORE::length($bin))
b3abae2a
JH
2274 {
2275 $bin = '0'; # shifting to far right creates -1
2276 # 0, because later increment makes
2277 # that 1, attached '-' makes it '-1'
2278 # because -1 >> x == -1 !
2279 }
2280 else
2281 {
2282 $bin =~ s/.{$y}$//; # cut off at the right side
2283 $bin = '1' . $bin; # extend left side by one dummy '1'
2284 $bin =~ tr/10/01/; # flip bits back
2285 }
2286 my $res = $self->new('0b'.$bin); # add prefix and convert back
2287 $res->binc(); # remember to increment
2288 $x->{value} = $res->{value}; # take over value
f9a08e12 2289 return $x->round(@r); # we are done now, magic, isn't?
b3abae2a 2290 }
b282a552 2291 # x < 0, n == 2, y == 1
b3abae2a
JH
2292 $x->bdec(); # n == 2, but $y == 1: this fixes it
2293 }
2294
9b924220
RGS
2295 $x->{value} = $CALC->_rsft($x->{value},$y->{value},$n);
2296 $x->round(@r);
58cde26e
JH
2297 }
2298
2299sub band
2300 {
2301 #(BINT or num_str, BINT or num_str) return BINT
2302 # compute x & y
1aa3c823 2303
f9a08e12
JH
2304 # set up parameters
2305 my ($self,$x,$y,@r) = (ref($_[0]),@_);
2306 # objectify is costly, so avoid it
2307 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
2308 {
2309 ($self,$x,$y,@r) = objectify(2,@_);
2310 }
1aa3c823 2311
58cde26e
JH
2312 return $x if $x->modify('band');
2313
f9a08e12 2314 $r[3] = $y; # no push!
b3abae2a 2315
58cde26e 2316 return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
0716bf9b 2317
b282a552
T
2318 my $sx = $x->{sign} eq '+' ? 1 : -1;
2319 my $sy = $y->{sign} eq '+' ? 1 : -1;
1aa3c823 2320
9b924220 2321 if ($sx == 1 && $sy == 1)
0716bf9b 2322 {
574bacfe 2323 $x->{value} = $CALC->_and($x->{value},$y->{value});
f9a08e12 2324 return $x->round(@r);
0716bf9b 2325 }
1aa3c823 2326
091c87b1
T
2327 if ($CAN{signed_and})
2328 {
2329 $x->{value} = $CALC->_signed_and($x->{value},$y->{value},$sx,$sy);
2330 return $x->round(@r);
2331 }
1aa3c823 2332
b282a552
T
2333 require $EMU_LIB;
2334 __emu_band($self,$x,$y,$sx,$sy,@r);
58cde26e
JH
2335 }
2336
2337sub bior
2338 {
2339 #(BINT or num_str, BINT or num_str) return BINT
2340 # compute x | y
1aa3c823 2341
f9a08e12
JH
2342 # set up parameters
2343 my ($self,$x,$y,@r) = (ref($_[0]),@_);
2344 # objectify is costly, so avoid it
2345 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
2346 {
2347 ($self,$x,$y,@r) = objectify(2,@_);
2348 }
58cde26e
JH
2349
2350 return $x if $x->modify('bior');
f9a08e12 2351 $r[3] = $y; # no push!
58cde26e
JH
2352
2353 return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
574bacfe 2354
b282a552
T
2355 my $sx = $x->{sign} eq '+' ? 1 : -1;
2356 my $sy = $y->{sign} eq '+' ? 1 : -1;
574bacfe 2357
091c87b1 2358 # the sign of X follows the sign of X, e.g. sign of Y irrelevant for bior()
1aa3c823 2359
574bacfe 2360 # don't use lib for negative values
9b924220 2361 if ($sx == 1 && $sy == 1)
0716bf9b 2362 {
574bacfe 2363 $x->{value} = $CALC->_or($x->{value},$y->{value});
f9a08e12 2364 return $x->round(@r);
0716bf9b
JH
2365 }
2366
b282a552 2367 # if lib can do negative values, let it handle this
091c87b1
T
2368 if ($CAN{signed_or})
2369 {
2370 $x->{value} = $CALC->_signed_or($x->{value},$y->{value},$sx,$sy);
2371 return $x->round(@r);
2372 }
2373
b282a552
T
2374 require $EMU_LIB;
2375 __emu_bior($self,$x,$y,$sx,$sy,@r);
58cde26e
JH
2376 }
2377
2378sub bxor
2379 {
2380 #(BINT or num_str, BINT or num_str) return BINT
2381 # compute x ^ y
1aa3c823 2382
f9a08e12
JH
2383 # set up parameters
2384 my ($self,$x,$y,@r) = (ref($_[0]),@_);
2385 # objectify is costly, so avoid it
2386 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
2387 {
2388 ($self,$x,$y,@r) = objectify(2,@_);
2389 }
58cde26e
JH
2390
2391 return $x if $x->modify('bxor');
f9a08e12 2392 $r[3] = $y; # no push!
58cde26e 2393
0716bf9b 2394 return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
1aa3c823 2395
b282a552
T
2396 my $sx = $x->{sign} eq '+' ? 1 : -1;
2397 my $sy = $y->{sign} eq '+' ? 1 : -1;
574bacfe
JH
2398
2399 # don't use lib for negative values
9b924220 2400 if ($sx == 1 && $sy == 1)
0716bf9b 2401 {
574bacfe 2402 $x->{value} = $CALC->_xor($x->{value},$y->{value});
f9a08e12 2403 return $x->round(@r);
0716bf9b 2404 }
1aa3c823 2405
b282a552 2406 # if lib can do negative values, let it handle this
091c87b1
T
2407 if ($CAN{signed_xor})
2408 {
2409 $x->{value} = $CALC->_signed_xor($x->{value},$y->{value},$sx,$sy);
2410 return $x->round(@r);
2411 }
0716bf9b 2412
b282a552
T
2413 require $EMU_LIB;
2414 __emu_bxor($self,$x,$y,$sx,$sy,@r);
58cde26e
JH
2415 }
2416
2417sub length
2418 {
b282a552 2419 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
58cde26e 2420
0716bf9b 2421 my $e = $CALC->_len($x->{value});
091c87b1 2422 wantarray ? ($e,0) : $e;
58cde26e
JH
2423 }
2424
2425sub digit
2426 {
0716bf9b 2427 # return the nth decimal digit, negative values count backward, 0 is right
ef9466ea 2428 my ($self,$x,$n) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
58cde26e 2429
ef9466ea 2430 $n = $n->numify() if ref($n);
f9a08e12 2431 $CALC->_digit($x->{value},$n||0);
58cde26e
JH
2432 }
2433
2434sub _trailing_zeros
2435 {
b282a552 2436 # return the amount of trailing zeros in $x (as scalar)
58cde26e
JH
2437 my $x = shift;
2438 $x = $class->new($x) unless ref $x;
2439
9b924220 2440 return 0 if $x->{sign} !~ /^[+-]$/; # NaN, inf, -inf etc
0716bf9b 2441
9b924220 2442 $CALC->_zeros($x->{value}); # must handle odd values, 0 etc
58cde26e
JH
2443 }
2444
2445sub bsqrt
2446 {
990fb837 2447 # calculate square root of $x
b68b7ab1 2448 my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
58cde26e 2449
b3abae2a
JH
2450 return $x if $x->modify('bsqrt');
2451
990fb837
RGS
2452 return $x->bnan() if $x->{sign} !~ /^\+/; # -x or -inf or NaN => NaN
2453 return $x if $x->{sign} eq '+inf'; # sqrt(+inf) == inf
b3abae2a 2454
f9a08e12 2455 return $upgrade->bsqrt($x,@r) if defined $upgrade;
58cde26e 2456
9b924220
RGS
2457 $x->{value} = $CALC->_sqrt($x->{value});
2458 $x->round(@r);
58cde26e
JH
2459 }
2460
990fb837
RGS
2461sub broot
2462 {
2463 # calculate $y'th root of $x
1aa3c823 2464
990fb837
RGS
2465 # set up parameters
2466 my ($self,$x,$y,@r) = (ref($_[0]),@_);
c38b2de2
JH
2467
2468 $y = $self->new(2) unless defined $y;
2469
990fb837 2470 # objectify is costly, so avoid it
c38b2de2 2471 if ((!ref($x)) || (ref($x) ne ref($y)))
990fb837 2472 {
3a427a11 2473 ($self,$x,$y,@r) = objectify(2,$self || $class,@_);
990fb837
RGS
2474 }
2475
2476 return $x if $x->modify('broot');
2477
2478 # NaN handling: $x ** 1/0, x or y NaN, or y inf/-inf or y == 0
2479 return $x->bnan() if $x->{sign} !~ /^\+/ || $y->is_zero() ||
2480 $y->{sign} !~ /^\+$/;
2481
2482 return $x->round(@r)
2483 if $x->is_zero() || $x->is_one() || $x->is_inf() || $y->is_one();
2484
c38b2de2 2485 return $upgrade->new($x)->broot($upgrade->new($y),@r) if defined $upgrade;
990fb837 2486
9b924220
RGS
2487 $x->{value} = $CALC->_root($x->{value},$y->{value});
2488 $x->round(@r);
990fb837
RGS
2489 }
2490
58cde26e
JH
2491sub exponent
2492 {
2493 # return a copy of the exponent (here always 0, NaN or 1 for $m == 0)
ee15d750 2494 my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
1aa3c823 2495
ee15d750
JH
2496 if ($x->{sign} !~ /^[+-]$/)
2497 {
b282a552
T
2498 my $s = $x->{sign}; $s =~ s/^[+-]//; # NaN, -inf,+inf => NaN or inf
2499 return $self->new($s);
ee15d750 2500 }
b282a552
T
2501 return $self->bone() if $x->is_zero();
2502
7d193e39
T
2503 # 12300 => 2 trailing zeros => exponent is 2
2504 $self->new( $CALC->_zeros($x->{value}) );
58cde26e
JH
2505 }
2506
2507sub mantissa
2508 {
ee15d750
JH
2509 # return the mantissa (compatible to Math::BigFloat, e.g. reduced)
2510 my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
58cde26e 2511
ee15d750
JH
2512 if ($x->{sign} !~ /^[+-]$/)
2513 {
b282a552
T
2514 # for NaN, +inf, -inf: keep the sign
2515 return $self->new($x->{sign});
ee15d750 2516 }
b282a552 2517 my $m = $x->copy(); delete $m->{_p}; delete $m->{_a};
7d193e39 2518
b282a552 2519 # that's a bit inefficient:
7d193e39 2520 my $zeros = $CALC->_zeros($m->{value});
56b9c951 2521 $m->brsft($zeros,10) if $zeros != 0;
56b9c951 2522 $m;
58cde26e
JH
2523 }
2524
2525sub parts
2526 {
ee15d750 2527 # return a copy of both the exponent and the mantissa
091c87b1 2528 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
58cde26e 2529
091c87b1 2530 ($x->mantissa(),$x->exponent());
58cde26e 2531 }
1aa3c823 2532
58cde26e
JH
2533##############################################################################
2534# rounding functions
2535
2536sub bfround
2537 {
2538 # precision: round to the $Nth digit left (+$n) or right (-$n) from the '.'
ee15d750 2539 # $n == 0 || $n == 1 => round to integer
ef9466ea 2540 my $x = shift; my $self = ref($x) || $x; $x = $self->new($x) unless ref $x;
b282a552 2541
b68b7ab1 2542 my ($scale,$mode) = $x->_scale_p(@_);
b282a552
T
2543
2544 return $x if !defined $scale || $x->modify('bfround'); # no-op
58cde26e
JH
2545
2546 # no-op for BigInts if $n <= 0
b282a552 2547 $x->bround( $x->length()-$scale, $mode) if $scale > 0;
58cde26e 2548
ef9466ea
T
2549 delete $x->{_a}; # delete to save memory
2550 $x->{_p} = $scale; # store new _p
ee15d750 2551 $x;
58cde26e
JH
2552 }
2553
2554sub _scan_for_nonzero
2555 {
ae161977
RGS
2556 # internal, used by bround() to scan for non-zeros after a '5'
2557 my ($x,$pad,$xs,$len) = @_;
1aa3c823 2558
ae161977 2559 return 0 if $len == 1; # "5" is trailed by invisible zeros
58cde26e
JH
2560 my $follow = $pad - 1;
2561 return 0 if $follow > $len || $follow < 1;
0716bf9b 2562
ae161977
RGS
2563 # use the string form to check whether only '0's follow or not
2564 substr ($xs,-$follow) =~ /[^0]/ ? 1 : 0;
58cde26e
JH
2565 }
2566
2567sub fround
2568 {
091c87b1
T
2569 # Exists to make life easier for switch between MBF and MBI (should we
2570 # autoload fxxx() like MBF does for bxxx()?)
b68b7ab1 2571 my $x = shift; $x = $class->new($x) unless ref $x;
091c87b1 2572 $x->bround(@_);
58cde26e
JH
2573 }
2574
2575sub bround
2576 {
2577 # accuracy: +$n preserve $n digits from left,
2578 # -$n preserve $n digits from right (f.i. for 0.1234 style in MBF)
2579 # no-op for $n == 0
2580 # and overwrite the rest with 0's, return normalized number
2581 # do not return $x->bnorm(), but $x
61f5c3f5 2582
58cde26e 2583 my $x = shift; $x = $class->new($x) unless ref $x;
b68b7ab1
T
2584 my ($scale,$mode) = $x->_scale_a(@_);
2585 return $x if !defined $scale || $x->modify('bround'); # no-op
1aa3c823 2586
61f5c3f5
T
2587 if ($x->is_zero() || $scale == 0)
2588 {
2589 $x->{_a} = $scale if !defined $x->{_a} || $x->{_a} > $scale; # 3 > 2
2590 return $x;
2591 }
2592 return $x if $x->{sign} !~ /^[+-]$/; # inf, NaN
58cde26e
JH
2593
2594 # we have fewer digits than we want to scale to
2595 my $len = $x->length();
56d9de68
T
2596 # convert $scale to a scalar in case it is an object (put's a limit on the
2597 # number length, but this would already limited by memory constraints), makes
2598 # it faster
2599 $scale = $scale->numify() if ref ($scale);
2600
ee15d750
JH
2601 # scale < 0, but > -len (not >=!)
2602 if (($scale < 0 && $scale < -$len-1) || ($scale >= $len))
2603 {
61f5c3f5 2604 $x->{_a} = $scale if !defined $x->{_a} || $x->{_a} > $scale; # 3 > 2
ee15d750
JH
2605 return $x;
2606 }
1aa3c823 2607
58cde26e
JH
2608 # count of 0's to pad, from left (+) or right (-): 9 - +6 => 3, or |-6| => 6
2609 my ($pad,$digit_round,$digit_after);
2610 $pad = $len - $scale;
ee15d750
JH
2611 $pad = abs($scale-1) if $scale < 0;
2612
ae161977
RGS
2613 # do not use digit(), it is very costly for binary => decimal
2614 # getting the entire string is also costly, but we need to do it only once
0716bf9b
JH
2615 my $xs = $CALC->_str($x->{value});
2616 my $pl = -$pad-1;
56d9de68 2617
0716bf9b
JH
2618 # pad: 123: 0 => -1, at 1 => -2, at 2 => -3, at 3 => -4
2619 # pad+1: 123: 0 => 0, at 1 => -1, at 2 => -2, at 3 => -3
9b924220 2620 $digit_round = '0'; $digit_round = substr($xs,$pl,1) if $pad <= $len;
0716bf9b 2621 $pl++; $pl ++ if $pad >= $len;
9b924220 2622 $digit_after = '0'; $digit_after = substr($xs,$pl,1) if $pad > 0;
ee15d750 2623
58cde26e
JH
2624 # in case of 01234 we round down, for 6789 up, and only in case 5 we look
2625 # closer at the remaining digits of the original $x, remember decision
2626 my $round_up = 1; # default round up
2627 $round_up -- if
2628 ($mode eq 'trunc') || # trunc by round down
2629 ($digit_after =~ /[01234]/) || # round down anyway,
2630 # 6789 => round up
2631 ($digit_after eq '5') && # not 5000...0000
ae161977 2632 ($x->_scan_for_nonzero($pad,$xs,$len) == 0) &&
58cde26e
JH
2633 (
2634 ($mode eq 'even') && ($digit_round =~ /[24680]/) ||
2635 ($mode eq 'odd') && ($digit_round =~ /[13579]/) ||
2636 ($mode eq '+inf') && ($x->{sign} eq '-') ||
2637 ($mode eq '-inf') && ($x->{sign} eq '+') ||
2638 ($mode eq 'zero') # round down if zero, sign adjusted below
2639 );
61f5c3f5
T
2640 my $put_back = 0; # not yet modified
2641
61f5c3f5
T
2642 if (($pad > 0) && ($pad <= $len))
2643 {
ae161977
RGS
2644 substr($xs,-$pad,$pad) = '0' x $pad; # replace with '00...'
2645 $put_back = 1; # need to put back
58cde26e 2646 }
61f5c3f5
T
2647 elsif ($pad > $len)
2648 {
2649 $x->bzero(); # round to '0'
2650 }
2651
58cde26e
JH
2652 if ($round_up) # what gave test above?
2653 {
ae161977 2654 $put_back = 1; # need to put back
9b924220 2655 $pad = $len, $xs = '0' x $pad if $scale < 0; # tlr: whack 0.51=>1.0
61f5c3f5
T
2656
2657 # we modify directly the string variant instead of creating a number and
f9a08e12 2658 # adding it, since that is faster (we already have the string)
61f5c3f5
T
2659 my $c = 0; $pad ++; # for $pad == $len case
2660 while ($pad <= $len)
2661 {
9b924220
RGS
2662 $c = substr($xs,-$pad,1) + 1; $c = '0' if $c eq '10';
2663 substr($xs,-$pad,1) = $c; $pad++;
61f5c3f5
T
2664 last if $c != 0; # no overflow => early out
2665 }
9b924220 2666 $xs = '1'.$xs if $c == 0;
61f5c3f5 2667
58cde26e 2668 }
ae161977 2669 $x->{value} = $CALC->_new($xs) if $put_back == 1; # put back, if needed
ee15d750
JH
2670
2671 $x->{_a} = $scale if $scale >= 0;
2672 if ($scale < 0)
2673 {
2674 $x->{_a} = $len+$scale;
2675 $x->{_a} = 0 if $scale < -$len;
2676 }
58cde26e
JH
2677 $x;
2678 }
2679
2680sub bfloor
2681 {
6358232b 2682 # round towards minus infinity; no-op since it's already integer
091c87b1 2683 my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
58cde26e 2684
f9a08e12 2685 $x->round(@r);
58cde26e
JH
2686 }
2687
2688sub bceil
2689 {
6358232b 2690 # round towards plus infinity; no-op since it's already int
091c87b1 2691 my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
58cde26e 2692
f9a08e12 2693 $x->round(@r);
58cde26e
JH
2694 }
2695
6358232b
PJA
2696sub bint {
2697 # round towards zero; no-op since it's already integer
2698 my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
2699
2700 $x->round(@r);
2701}
2702
091c87b1
T
2703sub as_number
2704 {
2705 # An object might be asked to return itself as bigint on certain overloaded
7b29e1e6 2706 # operations. This does exactly this, so that sub classes can simple inherit
091c87b1
T
2707 # it or override with their own integer conversion routine.
2708 $_[0]->copy();
2709 }
58cde26e 2710
091c87b1 2711sub as_hex
58cde26e 2712 {
091c87b1
T
2713 # return as hex string, with prefixed 0x
2714 my $x = shift; $x = $class->new($x) if !ref($x);
2715
2716 return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
2717
b282a552 2718 my $s = '';
091c87b1 2719 $s = $x->{sign} if $x->{sign} eq '-';
9b924220 2720 $s . $CALC->_as_hex($x->{value});
58cde26e
JH
2721 }
2722
091c87b1 2723sub as_bin
58cde26e 2724 {
091c87b1
T
2725 # return as binary string, with prefixed 0b
2726 my $x = shift; $x = $class->new($x) if !ref($x);
2727
2728 return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
2729
b282a552 2730 my $s = ''; $s = $x->{sign} if $x->{sign} eq '-';
9b924220 2731 return $s . $CALC->_as_bin($x->{value});
58cde26e
JH
2732 }
2733
7b29e1e6
T
2734sub as_oct
2735 {
2736 # return as octal string, with prefixed 0
2737 my $x = shift; $x = $class->new($x) if !ref($x);
2738
2739 return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
2740
2741 my $s = ''; $s = $x->{sign} if $x->{sign} eq '-';
2742 return $s . $CALC->_as_oct($x->{value});
2743 }
2744
091c87b1
T
2745##############################################################################
2746# private stuff (internal use only)
2747
66a04958
PJA
2748sub objectify {
2749 # Convert strings and "foreign objects" to the objects we want.
2750
2751 # The first argument, $count, is the number of following arguments that
2752 # objectify() looks at and converts to objects. The first is a classname.
2753 # If the given count is 0, all arguments will be used.
2754
2755 # After the count is read, objectify obtains the name of the class to which
2756 # the following arguments are converted. If the second argument is a
2757 # reference, use the reference type as the class name. Otherwise, if it is
2758 # a string that looks like a class name, use that. Otherwise, use $class.
2759
2760 # Caller: Gives us:
2761 #
2762 # $x->badd(1); => ref x, scalar y
2763 # Class->badd(1,2); => classname x (scalar), scalar x, scalar y
2764 # Class->badd(Class->(1),2); => classname x (scalar), ref x, scalar y
2765 # Math::BigInt::badd(1,2); => scalar x, scalar y
2766
2767 # A shortcut for the common case $x->unary_op():
2768
2769 return (ref($_[1]), $_[1]) if (@_ == 2) && ($_[0]||0 == 1) && ref($_[1]);
2770
2771 # Check the context.
2772
2773 unless (wantarray) {
2774 require Carp;
2775 Carp::croak ("${class}::objectify() needs list context");
58cde26e 2776 }
66a04958
PJA
2777
2778 # Get the number of arguments to objectify.
2779
2780 my $count = shift;
2781 $count ||= @_;
2782
2783 # Initialize the output array.
2784
2785 my @a = @_;
2786
2787 # If the first argument is a reference, use that reference type as our
2788 # class name. Otherwise, if the first argument looks like a class name,
2789 # then use that as our class name. Otherwise, use the default class name.
2790
58cde26e 2791 {
66a04958
PJA
2792 if (ref($a[0])) { # reference?
2793 unshift @a, ref($a[0]);
2794 last;
2795 }
2796 if ($a[0] =~ /^[A-Z].*::/) { # string with class name?
2797 last;
2798 }
2799 unshift @a, $class; # default class name
58cde26e 2800 }
8f675a64 2801
66a04958
PJA
2802 no strict 'refs';
2803
2804 # What we upgrade to, if anything.
2805
2806 my $up = ${"$a[0]::upgrade"};
2807
2808 # Disable downgrading, because Math::BigFloat -> foo('1.0','2.0') needs
2809 # floats.
2810
2811 my $down;
2812 if (defined ${"$a[0]::downgrade"}) {
2813 $down = ${"$a[0]::downgrade"};
2814 ${"$a[0]::downgrade"} = undef;
9393ace2
JH
2815 }
2816
66a04958
PJA
2817 for my $i (1 .. $count) {
2818 my $ref = ref $a[$i];
2819
0f9d2858 2820 # Perl scalars are fed to the appropriate constructor.
66a04958 2821
0f9d2858
PJA
2822 unless ($ref) {
2823 $a[$i] = $a[0] -> new($a[$i]);
66a04958 2824 next;
58cde26e 2825 }
66a04958 2826
0f9d2858 2827 # If it is an object of the right class, all is fine.
66a04958 2828
06ce15ad 2829 next if $ref -> isa($a[0]);
66a04958
PJA
2830
2831 # Upgrading is OK, so skip further tests if the argument is upgraded.
2832
0f9d2858 2833 if (defined $up && $ref -> isa($up)) {
66a04958
PJA
2834 next;
2835 }
2836
06ce15ad
SH
2837 # See if we can call one of the as_xxx() methods. We don't know whether
2838 # the as_xxx() method returns an object or a scalar, so re-check
2839 # afterwards.
66a04958 2840
06ce15ad
SH
2841 my $recheck = 0;
2842
2843 if ($a[0] -> isa('Math::BigInt')) {
66a04958
PJA
2844 if ($a[$i] -> can('as_int')) {
2845 $a[$i] = $a[$i] -> as_int();
06ce15ad
SH
2846 $recheck = 1;
2847 } elsif ($a[$i] -> can('as_number')) {
66a04958 2848 $a[$i] = $a[$i] -> as_number();
06ce15ad 2849 $recheck = 1;
66a04958
PJA
2850 }
2851 }
2852
06ce15ad 2853 elsif ($a[0] -> isa('Math::BigFloat')) {
66a04958
PJA
2854 if ($a[$i] -> can('as_float')) {
2855 $a[$i] = $a[$i] -> as_float();
06ce15ad
SH
2856 $recheck = $1;
2857 }
2858 }
2859
2860 # If we called one of the as_xxx() methods, recheck.
2861
2862 if ($recheck) {
2863 $ref = ref($a[$i]);
2864
2865 # Perl scalars are fed to the appropriate constructor.
2866
2867 unless ($ref) {
2868 $a[$i] = $a[0] -> new($a[$i]);
66a04958
PJA
2869 next;
2870 }
06ce15ad
SH
2871
2872 # If it is an object of the right class, all is fine.
2873
2874 next if $ref -> isa($a[0]);
66a04958
PJA
2875 }
2876
2877 # Last resort.
2878
2879 $a[$i] = $a[0] -> new($a[$i]);
990fb837 2880 }
66a04958
PJA
2881
2882 # Reset the downgrading.
2883
2884 ${"$a[0]::downgrade"} = $down;
2885
2886 return @a;
2887}
58cde26e 2888
b68b7ab1
T
2889sub _register_callback
2890 {
2891 my ($class,$callback) = @_;
2892
2893 if (ref($callback) ne 'CODE')
2894 {
2895 require Carp;
2896 Carp::croak ("$callback is not a coderef");
2897 }
2898 $CALLBACKS{$class} = $callback;
2899 }
2900
58cde26e
JH
2901sub import
2902 {
2903 my $self = shift;
61f5c3f5 2904
091c87b1 2905 $IMPORT++; # remember we did import()
8f675a64 2906 my @a; my $l = scalar @_;
7b29e1e6 2907 my $warn_or_die = 0; # 0 - no warn, 1 - warn, 2 - die
8f675a64 2908 for ( my $i = 0; $i < $l ; $i++ )
58cde26e 2909 {
0716bf9b 2910 if ($_[$i] eq ':constant')
58cde26e 2911 {
0716bf9b 2912 # this causes overlord er load to step in
091c87b1
T
2913 overload::constant
2914 integer => sub { $self->new(shift) },
2915 binary => sub { $self->new(shift) };
0716bf9b 2916 }
b3abae2a
JH
2917 elsif ($_[$i] eq 'upgrade')
2918 {
2919 # this causes upgrading
2920 $upgrade = $_[$i+1]; # or undef to disable
8f675a64 2921 $i++;
b3abae2a 2922 }
7b29e1e6 2923 elsif ($_[$i] =~ /^(lib|try|only)\z/)
0716bf9b
JH
2924 {
2925 # this causes a different low lib to take care...
61f5c3f5 2926 $CALC = $_[$i+1] || '';
7b29e1e6
T
2927 # lib => 1 (warn on fallback), try => 0 (no warn), only => 2 (die on fallback)
2928 $warn_or_die = 1 if $_[$i] eq 'lib';
2929 $warn_or_die = 2 if $_[$i] eq 'only';
8f675a64
JH
2930 $i++;
2931 }
2932 else
2933 {
2934 push @a, $_[$i];
58cde26e
JH
2935 }
2936 }
2937 # any non :constant stuff is handled by our parent, Exporter
b68b7ab1
T
2938 if (@a > 0)
2939 {
2940 require Exporter;
1aa3c823 2941
b68b7ab1
T
2942 $self->SUPER::import(@a); # need it for subclasses
2943 $self->export_to_level(1,$self,@a); # need it for MBF
2944 }
58cde26e 2945
574bacfe
JH
2946 # try to load core math lib
2947 my @c = split /\s*,\s*/,$CALC;
b68b7ab1
T
2948 foreach (@c)
2949 {
2950 $_ =~ tr/a-zA-Z0-9://cd; # limit to sane characters
2951 }
a90064ab 2952 push @c, \'Calc' # if all fail, try these
7b29e1e6 2953 if $warn_or_die < 2; # but not for "only"
61f5c3f5 2954 $CALC = ''; # signal error
7b29e1e6 2955 foreach my $l (@c)
574bacfe 2956 {
7b29e1e6
T
2957 # fallback libraries are "marked" as \'string', extract string if nec.
2958 my $lib = $l; $lib = $$l if ref($l);
2959
07d34614 2960 next if ($lib || '') eq '';
574bacfe
JH
2961 $lib = 'Math::BigInt::'.$lib if $lib !~ /^Math::BigInt/i;
2962 $lib =~ s/\.pm$//;
61f5c3f5 2963 if ($] < 5.006)
574bacfe 2964 {
b68b7ab1
T
2965 # Perl < 5.6.0 dies with "out of memory!" when eval("") and ':constant' is
2966 # used in the same script, or eval("") inside import().
07d34614
T
2967 my @parts = split /::/, $lib; # Math::BigInt => Math BigInt
2968 my $file = pop @parts; $file .= '.pm'; # BigInt => BigInt.pm
2969 require File::Spec;
2970 $file = File::Spec->catfile (@parts, $file);
2971 eval { require "$file"; $lib->import( @c ); }
574bacfe
JH
2972 }
2973 else
2974 {
61f5c3f5 2975 eval "use $lib qw/@c/;";
574bacfe 2976 }
9b924220
RGS
2977 if ($@ eq '')
2978 {
2979 my $ok = 1;
2980 # loaded it ok, see if the api_version() is high enough
2981 if ($lib->can('api_version') && $lib->api_version() >= 1.0)
2982 {
2983 $ok = 0;
2984 # api_version matches, check if it really provides anything we need
2985 for my $method (qw/
2986 one two ten
2987 str num
2988 add mul div sub dec inc
2989 acmp len digit is_one is_zero is_even is_odd
2990 is_two is_ten
7b29e1e6
T
2991 zeros new copy check
2992 from_hex from_oct from_bin as_hex as_bin as_oct
9b924220
RGS
2993 rsft lsft xor and or
2994 mod sqrt root fac pow modinv modpow log_int gcd
2995 /)
2996 {
2997 if (!$lib->can("_$method"))
2998 {
2999 if (($WARN{$lib}||0) < 2)
3000 {
3001 require Carp;
3002 Carp::carp ("$lib is missing method '_$method'");
3003 $WARN{$lib} = 1; # still warn about the lib
3004 }
3005 $ok++; last;
3006 }
3007 }
3008 }
3009 if ($ok == 0)
3010 {
3011 $CALC = $lib;
7b29e1e6
T
3012 if ($warn_or_die > 0 && ref($l))
3013 {
3014 require Carp;
1aa3c823
JK
3015 my $msg =
3016 "Math::BigInt: couldn't load specified math lib(s), fallback to $lib";
7b29e1e6
T
3017 Carp::carp ($msg) if $warn_or_die == 1;
3018 Carp::croak ($msg) if $warn_or_die == 2;
3019 }
9b924220
RGS
3020 last; # found a usable one, break
3021 }
3022 else
3023 {
3024 if (($WARN{$lib}||0) < 2)
3025 {
a87115f0 3026 my $ver = eval "\$$lib\::VERSION" || 'unknown';
9b924220
RGS
3027 require Carp;
3028 Carp::carp ("Cannot load outdated $lib v$ver, please upgrade");
3029 $WARN{$lib} = 2; # never warn again
3030 }
3031 }
3032 }
574bacfe 3033 }
990fb837
RGS
3034 if ($CALC eq '')
3035 {
3036 require Carp;
7b29e1e6
T
3037 if ($warn_or_die == 2)
3038 {
1aa3c823
JK
3039 Carp::croak(
3040 "Couldn't load specified math lib(s) and fallback disallowed");
7b29e1e6
T
3041 }
3042 else
3043 {
1aa3c823
JK
3044 Carp::croak(
3045 "Couldn't load any math lib(s), not even fallback to Calc.pm");
7b29e1e6 3046 }
091c87b1 3047 }
091c87b1 3048
b68b7ab1
T
3049 # notify callbacks
3050 foreach my $class (keys %CALLBACKS)
3051 {
3052 &{$CALLBACKS{$class}}($CALC);
3053 }
3054
3055 # Fill $CAN with the results of $CALC->can(...) for emulating lower math lib
3056 # functions
091c87b1
T
3057
3058 %CAN = ();
b68b7ab1 3059 for my $method (qw/ signed_and signed_or signed_xor /)
091c87b1
T
3060 {
3061 $CAN{$method} = $CALC->can("_$method") ? 1 : 0;
990fb837 3062 }
b68b7ab1
T
3063
3064 # import done
58cde26e
JH
3065 }
3066
de1ac46b
PJA
3067sub from_hex {
3068 # Create a bigint from a hexadecimal string.
7b29e1e6 3069
de1ac46b 3070 my ($self, $str) = @_;
7b29e1e6 3071
de1ac46b
PJA
3072 if ($str =~ s/
3073 ^
3074 ( [+-]? )
3075 (0?x)?
3076 (
3077 [0-9a-fA-F]*
3078 ( _ [0-9a-fA-F]+ )*
3079 )
3080 $
3081 //x)
3082 {
3083 # Get a "clean" version of the string, i.e., non-emtpy and with no
3084 # underscores or invalid characters.
7b29e1e6 3085
de1ac46b
PJA
3086 my $sign = $1;
3087 my $chrs = $3;
3088 $chrs =~ tr/_//d;
3089 $chrs = '0' unless CORE::length $chrs;
7b29e1e6 3090
de1ac46b 3091 # Initialize output.
7b29e1e6 3092
de1ac46b 3093 my $x = Math::BigInt->bzero();
7b29e1e6 3094
de1ac46b 3095 # The library method requires a prefix.
7b29e1e6 3096
de1ac46b 3097 $x->{value} = $CALC->_from_hex('0x' . $chrs);
7b29e1e6 3098
de1ac46b 3099 # Place the sign.
7b29e1e6 3100
de1ac46b
PJA
3101 if ($sign eq '-' && ! $CALC->_is_zero($x->{value})) {
3102 $x->{sign} = '-';
3103 }
7b29e1e6 3104
de1ac46b
PJA
3105 return $x;
3106 }
7b29e1e6 3107
de1ac46b
PJA
3108 # CORE::hex() parses as much as it can, and ignores any trailing garbage.
3109 # For backwards compatibility, we return NaN.
7b29e1e6 3110
de1ac46b
PJA
3111 return $self->bnan();
3112}
58cde26e 3113
de1ac46b
PJA
3114sub from_oct {
3115 # Create a bigint from an octal string.
58cde26e 3116
de1ac46b 3117 my ($self, $str) = @_;
58cde26e 3118
de1ac46b
PJA
3119 if ($str =~ s/
3120 ^
3121 ( [+-]? )
3122 (
3123 [0-7]*
3124 ( _ [0-7]+ )*
3125 )
3126 $
3127 //x)
3128 {
3129 # Get a "clean" version of the string, i.e., non-emtpy and with no
3130 # underscores or invalid characters.
58cde26e 3131
de1ac46b
PJA
3132 my $sign = $1;
3133 my $chrs = $2;
3134 $chrs =~ tr/_//d;
3135 $chrs = '0' unless CORE::length $chrs;
58cde26e 3136
de1ac46b 3137 # Initialize output.
7b29e1e6 3138
de1ac46b 3139 my $x = Math::BigInt->bzero();
58cde26e 3140
de1ac46b 3141 # The library method requires a prefix.
9b924220 3142
de1ac46b
PJA
3143 $x->{value} = $CALC->_from_oct('0' . $chrs);
3144
3145 # Place the sign.
3146
3147 if ($sign eq '-' && ! $CALC->_is_zero($x->{value})) {
3148 $x->{sign} = '-';
3149 }
3150
3151 return $x;
3152 }
3153
3154 # CORE::oct() parses as much as it can, and ignores any trailing garbage.
3155 # For backwards compatibility, we return NaN.
3156
3157 return $self->bnan();
3158}
3159
3160sub from_bin {
3161 # Create a bigint from a binary string.
3162
3163 my ($self, $str) = @_;
3164
3165 if ($str =~ s/
3166 ^
3167 ( [+-]? )
3168 (0?b)?
3169 (
3170 [01]*
3171 ( _ [01]+ )*
3172 )
3173 $
3174 //x)
3175 {
3176 # Get a "clean" version of the string, i.e., non-emtpy and with no
3177 # underscores or invalid characters.
3178
3179 my $sign = $1;
3180 my $chrs = $3;
3181 $chrs =~ tr/_//d;
3182 $chrs = '0' unless CORE::length $chrs;
3183
3184 # Initialize output.
3185
3186 my $x = Math::BigInt->bzero();
3187
3188 # The library method requires a prefix.
3189
3190 $x->{value} = $CALC->_from_bin('0b' . $chrs);
3191
3192 # Place the sign.
3193
3194 if ($sign eq '-' && ! $CALC->_is_zero($x->{value})) {
3195 $x->{sign} = '-';
3196 }
3197
3198 return $x;
3199 }
3200
3201 # For consistency with from_hex() and from_oct(), we return NaN when the
3202 # input is invalid.
3203
3204 return $self->bnan();
3205}
58cde26e
JH
3206
3207sub _split
3208 {
b68b7ab1 3209 # input: num_str; output: undef for invalid or
1aa3c823
JK
3210 # (\$mantissa_sign,\$mantissa_value,\$mantissa_fraction,
3211 # \$exp_sign,\$exp_value)
b68b7ab1
T
3212 # Internal, take apart a string and return the pieces.
3213 # Strip leading/trailing whitespace, leading zeros, underscore and reject
3214 # invalid input.
58cde26e
JH
3215 my $x = shift;
3216
c4a6f826 3217 # strip white space at front, also extraneous leading zeros
7b29e1e6
T
3218 $x =~ s/^\s*([-]?)0*([0-9])/$1$2/g; # will not strip ' .2'
3219 $x =~ s/^\s+//; # but this will
3220 $x =~ s/\s+$//g; # strip white space at end
58cde26e 3221
574bacfe 3222 # shortcut, if nothing to split, return early
7b29e1e6 3223 if ($x =~ /^[+-]?[0-9]+\z/)
574bacfe 3224 {
9b924220
RGS
3225 $x =~ s/^([+-])0*([0-9])/$2/; my $sign = $1 || '+';
3226 return (\$sign, \$x, \'', \'', \0);
574bacfe 3227 }
58cde26e 3228
574bacfe 3229 # invalid starting char?
9b924220 3230 return if $x !~ /^[+-]?(\.?[0-9]|0b[0-1]|0x[0-9a-fA-F])/;
58cde26e 3231
de1ac46b
PJA
3232 return Math::BigInt->from_hex($x) if $x =~ /^[+-]?0x/; # hex string
3233 return Math::BigInt->from_bin($x) if $x =~ /^[+-]?0b/; # binary string
3234
394e6ffb 3235 # strip underscores between digits
7b29e1e6
T
3236 $x =~ s/([0-9])_([0-9])/$1$2/g;
3237 $x =~ s/([0-9])_([0-9])/$1$2/g; # do twice for 1_2_3
574bacfe 3238
58cde26e
JH
3239 # some possible inputs:
3240 # 2.1234 # 0.12 # 1 # 1E1 # 2.134E1 # 434E-10 # 1.02009E-2
aef458a0 3241 # .2 # 1_2_3.4_5_6 # 1.4E1_2_3 # 1e3 # +.2 # 0e999
58cde26e 3242
9b924220 3243 my ($m,$e,$last) = split /[Ee]/,$x;
56d9de68 3244 return if defined $last; # last defined => 1e2E3 or others
58cde26e 3245 $e = '0' if !defined $e || $e eq "";
56d9de68 3246
58cde26e
JH
3247 # sign,value for exponent,mantint,mantfrac
3248 my ($es,$ev,$mis,$miv,$mfv);
3249 # valid exponent?
7b29e1e6 3250 if ($e =~ /^([+-]?)0*([0-9]+)$/) # strip leading zeros
58cde26e
JH
3251 {
3252 $es = $1; $ev = $2;
58cde26e
JH
3253 # valid mantissa?
3254 return if $m eq '.' || $m eq '';
56d9de68 3255 my ($mi,$mf,$lastf) = split /\./,$m;
8df1e0a2 3256 return if defined $lastf; # lastf defined => 1.2.3 or others
58cde26e
JH
3257 $mi = '0' if !defined $mi;
3258 $mi .= '0' if $mi =~ /^[\-\+]?$/;
3259 $mf = '0' if !defined $mf || $mf eq '';
7b29e1e6 3260 if ($mi =~ /^([+-]?)0*([0-9]+)$/) # strip leading zeros
58cde26e
JH
3261 {
3262 $mis = $1||'+'; $miv = $2;
7b29e1e6 3263 return unless ($mf =~ /^([0-9]*?)0*$/); # strip trailing zeros
58cde26e 3264 $mfv = $1;
aef458a0
JH
3265 # handle the 0e999 case here
3266 $ev = 0 if $miv eq '0' && $mfv eq '';
58cde26e
JH
3267 return (\$mis,\$miv,\$mfv,\$es,\$ev);
3268 }
3269 }
3270 return; # NaN, not a number
3271 }
3272
58cde26e 3273##############################################################################
0716bf9b 3274# internal calculation routines (others are in Math::BigInt::Calc etc)
58cde26e 3275
dccbb853 3276sub __lcm
58cde26e
JH
3277 {
3278 # (BINT or num_str, BINT or num_str) return BINT
3279 # does modify first argument
3280 # LCM
1aa3c823 3281
b68b7ab1 3282 my ($x,$ty) = @_;
58cde26e 3283 return $x->bnan() if ($x->{sign} eq $nan) || ($ty->{sign} eq $nan);
b68b7ab1
T
3284 my $method = ref($x) . '::bgcd';
3285 no strict 'refs';
3286 $x * $ty / &$method($x,$ty);
58cde26e
JH
3287 }
3288
58cde26e 3289###############################################################################
fdb4b05f
T
3290# trigonometric functions
3291
3292sub bpi
3293 {
3294 # Calculate PI to N digits. Unless upgrading is in effect, returns the
3295 # result truncated to an integer, that is, always returns '3'.
3296 my ($self,$n) = @_;
3297 if (@_ == 1)
3298 {
3299 # called like Math::BigInt::bpi(10);
3300 $n = $self; $self = $class;
3301 }
3302 $self = ref($self) if ref($self);
3303
3304 return $upgrade->new($n) if defined $upgrade;
3305
3306 # hard-wired to "3"
3307 $self->new(3);
3308 }
3309
60a1aa19
T
3310sub bcos
3311 {
3312 # Calculate cosinus(x) to N digits. Unless upgrading is in effect, returns the
3313 # result truncated to an integer.
3314 my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
3315
3316 return $x if $x->modify('bcos');
3317
3318 return $x->bnan() if $x->{sign} !~ /^[+-]\z/; # -inf +inf or NaN => NaN
3319
3320 return $upgrade->new($x)->bcos(@r) if defined $upgrade;
3321
20e2035c 3322 require Math::BigFloat;
60a1aa19
T
3323 # calculate the result and truncate it to integer
3324 my $t = Math::BigFloat->new($x)->bcos(@r)->as_int();
3325
3326 $x->bone() if $t->is_one();
3327 $x->bzero() if $t->is_zero();
3328 $x->round(@r);
3329 }
3330
3331sub bsin
3332 {
3333 # Calculate sinus(x) to N digits. Unless upgrading is in effect, returns the
3334 # result truncated to an integer.
3335 my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
3336
3337 return $x if $x->modify('bsin');
3338
3339 return $x->bnan() if $x->{sign} !~ /^[+-]\z/; # -inf +inf or NaN => NaN
3340
3341 return $upgrade->new($x)->bsin(@r) if defined $upgrade;
3342
20e2035c 3343 require Math::BigFloat;
60a1aa19
T
3344 # calculate the result and truncate it to integer
3345 my $t = Math::BigFloat->new($x)->bsin(@r)->as_int();
3346
3347 $x->bone() if $t->is_one();
3348 $x->bzero() if $t->is_zero();
3349 $x->round(@r);
3350 }
3351
20e2035c
T
3352sub batan2
3353 {
30afc38d 3354 # calculate arcus tangens of ($y/$x)
1aa3c823 3355
20e2035c 3356 # set up parameters
30afc38d 3357 my ($self,$y,$x,@r) = (ref($_[0]),@_);
20e2035c
T
3358 # objectify is costly, so avoid it
3359 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
3360 {
30afc38d 3361 ($self,$y,$x,@r) = objectify(2,@_);
20e2035c
T
3362 }
3363
30afc38d 3364 return $y if $y->modify('batan2');
20e2035c 3365
30afc38d
T
3366 return $y->bnan() if ($y->{sign} eq $nan) || ($x->{sign} eq $nan);
3367
0dceeee6
RGS
3368 # Y X
3369 # != 0 -inf result is +- pi
3370 if ($x->is_inf() || $y->is_inf())
3371 {
3372 # upgrade to BigFloat etc.
3373 return $upgrade->new($y)->batan2($upgrade->new($x),@r) if defined $upgrade;
3374 if ($y->is_inf())
3375 {
3376 if ($x->{sign} eq '-inf')
3377 {
3378 # calculate 3 pi/4 => 2.3.. => 2
3379 $y->bone( substr($y->{sign},0,1) );
3380 $y->bmul($self->new(2));
3381 }
3382 elsif ($x->{sign} eq '+inf')
3383 {
3384 # calculate pi/4 => 0.7 => 0
3385 $y->bzero();
3386 }
3387 else
3388 {
3389 # calculate pi/2 => 1.5 => 1
3390 $y->bone( substr($y->{sign},0,1) );
3391 }
3392 }
3393 else
3394 {
3395 if ($x->{sign} eq '+inf')
3396 {
3397 # calculate pi/4 => 0.7 => 0
3398 $y->bzero();
3399 }
3400 else
3401 {
3402 # PI => 3.1415.. => 3
3403 $y->bone( substr($y->{sign},0,1) );
3404 $y->bmul($self->new(3));
3405 }
3406 }
3407 return $y;
3408 }
20e2035c 3409
30afc38d 3410 return $upgrade->new($y)->batan2($upgrade->new($x),@r) if defined $upgrade;
20e2035c
T
3411
3412 require Math::BigFloat;
1aa3c823
JK
3413 my $r = Math::BigFloat->new($y)
3414 ->batan2(Math::BigFloat->new($x),@r)
3415 ->as_int();
20e2035c
T
3416
3417 $x->{value} = $r->{value};
3418 $x->{sign} = $r->{sign};
3419
3420 $x;
3421 }
3422
60a1aa19
T
3423sub batan
3424 {
3425 # Calculate arcus tangens of x to N digits. Unless upgrading is in effect, returns the
3426 # result truncated to an integer.
3427 my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
3428
3429 return $x if $x->modify('batan');