BigInt.pm 198 KB
Newer Older
1 2 3 4 5 6 7 8
package Math::BigInt;

#
# "Mike had an infinite amount to do and a negative amount of time in which
# to do it." - Before and After
#

# The following hash values are used:
9
#   value: unsigned int with actual value (as a Math::BigInt::Calc or similar)
10
#   sign : +, -, NaN, +inf, -inf
11 12 13 14 15 16
#   _a   : accuracy
#   _p   : precision

# Remember not to take shortcuts ala $xs = $x->{value}; $CALC->foo($xs); since
# underlying lib might change the reference!

17
use 5.006001;
18 19
use strict;
use warnings;
20

21 22
use Carp ();

23
our $VERSION = '1.999806';
24

25 26
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(objectify bgcd blcm);
27

28
my $class = "Math::BigInt";
29 30

# Inside overload, the first arg is always an object. If the original code had
31
# it reversed (like $x = 2 * $y), then the third parameter is true.
32 33 34 35 36 37 38 39 40 41
# In some cases (like add, $x = $x + 2 is the same as $x = 2 + $x) this makes
# no difference, but in some cases it does.

# For overloaded ops with only one argument we simple use $_[0]->copy() to
# preserve the argument.

# Thus inheritance of overload operators becomes possible and transparent for
# our subclasses without the need to repeat the entire overload section there.

use overload
42 43 44 45 46 47

  # overload key: with_assign

  '+'     =>      sub { $_[0] -> copy() -> badd($_[1]); },

  '-'     =>      sub { my $c = $_[0] -> copy;
48
                        $_[2] ? $c -> bneg() -> badd($_[1])
49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196
                              : $c -> bsub($_[1]); },

  '*'     =>      sub { $_[0] -> copy() -> bmul($_[1]); },

  '/'     =>      sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bdiv($_[0])
                              : $_[0] -> copy -> bdiv($_[1]); },

  '%'     =>      sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bmod($_[0])
                              : $_[0] -> copy -> bmod($_[1]); },

  '**'    =>      sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bpow($_[0])
                              : $_[0] -> copy -> bpow($_[1]); },

  '<<'    =>      sub { $_[2] ? ref($_[0]) -> new($_[1]) -> blsft($_[0])
                              : $_[0] -> copy -> blsft($_[1]); },

  '>>'    =>      sub { $_[2] ? ref($_[0]) -> new($_[1]) -> brsft($_[0])
                              : $_[0] -> copy -> brsft($_[1]); },

  # overload key: assign

  '+='    =>      sub { $_[0]->badd($_[1]); },

  '-='    =>      sub { $_[0]->bsub($_[1]); },

  '*='    =>      sub { $_[0]->bmul($_[1]); },

  '/='    =>      sub { scalar $_[0]->bdiv($_[1]); },

  '%='    =>      sub { $_[0]->bmod($_[1]); },

  '**='   =>      sub { $_[0]->bpow($_[1]); },


  '<<='   =>      sub { $_[0]->blsft($_[1]); },

  '>>='   =>      sub { $_[0]->brsft($_[1]); },

#  'x='    =>      sub { },

#  '.='    =>      sub { },

  # overload key: num_comparison

  '<'     =>      sub { $_[2] ? ref($_[0]) -> new($_[1]) -> blt($_[0])
                              : $_[0] -> blt($_[1]); },

  '<='    =>      sub { $_[2] ? ref($_[0]) -> new($_[1]) -> ble($_[0])
                              : $_[0] -> ble($_[1]); },

  '>'     =>      sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bgt($_[0])
                              : $_[0] -> bgt($_[1]); },

  '>='    =>      sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bge($_[0])
                              : $_[0] -> bge($_[1]); },

  '=='    =>      sub { $_[0] -> beq($_[1]); },

  '!='    =>      sub { $_[0] -> bne($_[1]); },

  # overload key: 3way_comparison

  '<=>'   =>      sub { my $cmp = $_[0] -> bcmp($_[1]);
                        defined($cmp) && $_[2] ? -$cmp : $cmp; },

  'cmp'   =>      sub { $_[2] ? "$_[1]" cmp $_[0] -> bstr()
                              : $_[0] -> bstr() cmp "$_[1]"; },

  # overload key: str_comparison

#  'lt'     =>      sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrlt($_[0])
#                              : $_[0] -> bstrlt($_[1]); },
#
#  'le'    =>      sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrle($_[0])
#                              : $_[0] -> bstrle($_[1]); },
#
#  'gt'     =>      sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrgt($_[0])
#                              : $_[0] -> bstrgt($_[1]); },
#
#  'ge'    =>      sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrge($_[0])
#                              : $_[0] -> bstrge($_[1]); },
#
#  'eq'    =>      sub { $_[0] -> bstreq($_[1]); },
#
#  'ne'    =>      sub { $_[0] -> bstrne($_[1]); },

  # overload key: binary

  '&'     =>      sub { $_[2] ? ref($_[0]) -> new($_[1]) -> band($_[0])
                              : $_[0] -> copy -> band($_[1]); },

  '&='    =>      sub { $_[0] -> band($_[1]); },

  '|'     =>      sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bior($_[0])
                              : $_[0] -> copy -> bior($_[1]); },

  '|='    =>      sub { $_[0] -> bior($_[1]); },

  '^'     =>      sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bxor($_[0])
                              : $_[0] -> copy -> bxor($_[1]); },

  '^='    =>      sub { $_[0] -> bxor($_[1]); },

#  '&.'    =>      sub { },

#  '&.='   =>      sub { },

#  '|.'    =>      sub { },

#  '|.='   =>      sub { },

#  '^.'    =>      sub { },

#  '^.='   =>      sub { },

  # overload key: unary

  'neg'   =>      sub { $_[0] -> copy() -> bneg(); },

#  '!'     =>      sub { },

  '~'     =>      sub { $_[0] -> copy() -> bnot(); },

#  '~.'    =>      sub { },

  # overload key: mutators

  '++'    =>      sub { $_[0] -> binc() },

  '--'    =>      sub { $_[0] -> bdec() },

  # overload key: func

  'atan2' =>      sub { $_[2] ? ref($_[0]) -> new($_[1]) -> batan2($_[0])
                              : $_[0] -> copy() -> batan2($_[1]); },

  'cos'   =>      sub { $_[0] -> copy -> bcos(); },

  'sin'   =>      sub { $_[0] -> copy -> bsin(); },

  'exp'   =>      sub { $_[0] -> copy() -> bexp($_[1]); },

  'abs'   =>      sub { $_[0] -> copy() -> babs(); },

  'log'   =>      sub { $_[0] -> copy() -> blog(); },

  'sqrt'  =>      sub { $_[0] -> copy() -> bsqrt(); },

197
  'int'   =>      sub { $_[0] -> copy() -> bint(); },
198 199 200 201 202 203 204 205 206 207 208 209

  # overload key: conversion

  'bool'  =>      sub { $_[0] -> is_zero() ? '' : 1; },

  '""'    =>      sub { $_[0] -> bstr(); },

  '0+'    =>      sub { $_[0] -> numify(); },

  '='     =>      sub { $_[0]->copy(); },

  ;
210 211 212 213 214 215 216

##############################################################################
# global constants, flags and accessory

# These vars are public, but their direct usage is not recommended, use the
# accessor methods instead

217 218 219 220 221 222
our $round_mode = 'even'; # one of 'even', 'odd', '+inf', '-inf', 'zero', 'trunc' or 'common'
our $accuracy   = undef;
our $precision  = undef;
our $div_scale  = 40;
our $upgrade    = undef;                    # default is no upgrade
our $downgrade  = undef;                    # default is no downgrade
223 224 225

# These are internally, and not to be used from the outside at all

226 227 228
our $_trap_nan = 0;                         # are NaNs ok? set w/ config()
our $_trap_inf = 0;                         # are infs ok? set w/ config()

229
my $nan = 'NaN';                        # constants for easier life
230

231 232 233 234 235 236 237 238
my $CALC = 'Math::BigInt::Calc';        # module to do the low level math
                                        # default is Calc.pm
my $IMPORT = 0;                         # was import() called yet?
                                        # used to make require work
my %WARN;                               # warn only once for low-level libs
my %CAN;                                # cache for $CALC->can(...)
my %CALLBACKS;                          # callbacks to notify on lib loads
my $EMU_LIB = 'Math/BigInt/CalcEmu.pm'; # emulate low-level math
239 240 241 242

##############################################################################
# the old code had $rnd_mode, so we need to support it, too

243
our $rnd_mode   = 'even';
244

245 246 247 248
sub TIESCALAR {
    my ($class) = @_;
    bless \$round_mode, $class;
}
249

250 251 252
sub FETCH {
    return $round_mode;
}
253

254 255 256
sub STORE {
    $rnd_mode = $_[0]->round_mode($_[1]);
}
257

258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280
BEGIN {
    # tie to enable $rnd_mode to work transparently
    tie $rnd_mode, 'Math::BigInt';

    # set up some handy alias names
    *as_int = \&as_number;
    *is_pos = \&is_positive;
    *is_neg = \&is_negative;
}

###############################################################################
# Configuration methods
###############################################################################

sub round_mode {
    no strict 'refs';
    # make Class->round_mode() work
    my $self = shift;
    my $class = ref($self) || $self || __PACKAGE__;
    if (defined $_[0]) {
        my $m = shift;
        if ($m !~ /^(even|odd|\+inf|\-inf|zero|trunc|common)$/) {
            Carp::croak("Unknown round mode '$m'");
281
        }
282 283 284 285 286 287 288 289 290 291 292 293 294
        return ${"${class}::round_mode"} = $m;
    }
    ${"${class}::round_mode"};
}

sub upgrade {
    no strict 'refs';
    # make Class->upgrade() work
    my $self = shift;
    my $class = ref($self) || $self || __PACKAGE__;
    # need to set new value?
    if (@_ > 0) {
        return ${"${class}::upgrade"} = $_[0];
295
    }
296 297
    ${"${class}::upgrade"};
}
298

299 300 301 302 303 304 305 306 307 308 309
sub downgrade {
    no strict 'refs';
    # make Class->downgrade() work
    my $self = shift;
    my $class = ref($self) || $self || __PACKAGE__;
    # need to set new value?
    if (@_ > 0) {
        return ${"${class}::downgrade"} = $_[0];
    }
    ${"${class}::downgrade"};
}
310

311 312 313 314 315 316 317 318 319 320 321 322 323
sub div_scale {
    no strict 'refs';
    # make Class->div_scale() work
    my $self = shift;
    my $class = ref($self) || $self || __PACKAGE__;
    if (defined $_[0]) {
        if ($_[0] < 0) {
            Carp::croak('div_scale must be greater than zero');
        }
        ${"${class}::div_scale"} = $_[0];
    }
    ${"${class}::div_scale"};
}
324

325 326 327 328 329
sub accuracy {
    # $x->accuracy($a);           ref($x) $a
    # $x->accuracy();             ref($x)
    # Class->accuracy();          class
    # Class->accuracy($a);        class $a
330

331 332
    my $x = shift;
    my $class = ref($x) || $x || __PACKAGE__;
333

334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362
    no strict 'refs';
    # need to set new value?
    if (@_ > 0) {
        my $a = shift;
        # convert objects to scalars to avoid deep recursion. If object doesn't
        # have numify(), then hopefully it will have overloading for int() and
        # boolean test without wandering into a deep recursion path...
        $a = $a->numify() if ref($a) && $a->can('numify');

        if (defined $a) {
            # also croak on non-numerical
            if (!$a || $a <= 0) {
                Carp::croak('Argument to accuracy must be greater than zero');
            }
            if (int($a) != $a) {
                Carp::croak('Argument to accuracy must be an integer');
            }
        }
        if (ref($x)) {
            # $object->accuracy() or fallback to global
            $x->bround($a) if $a; # not for undef, 0
            $x->{_a} = $a;        # set/overwrite, even if not rounded
            delete $x->{_p};      # clear P
            $a = ${"${class}::accuracy"} unless defined $a; # proper return value
        } else {
            ${"${class}::accuracy"} = $a; # set global A
            ${"${class}::precision"} = undef; # clear global P
        }
        return $a;              # shortcut
363 364
    }

365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403
    my $a;
    # $object->accuracy() or fallback to global
    $a = $x->{_a} if ref($x);
    # but don't return global undef, when $x's accuracy is 0!
    $a = ${"${class}::accuracy"} if !defined $a;
    $a;
}

sub precision {
    # $x->precision($p);          ref($x) $p
    # $x->precision();            ref($x)
    # Class->precision();         class
    # Class->precision($p);       class $p

    my $x = shift;
    my $class = ref($x) || $x || __PACKAGE__;

    no strict 'refs';
    if (@_ > 0) {
        my $p = shift;
        # convert objects to scalars to avoid deep recursion. If object doesn't
        # have numify(), then hopefully it will have overloading for int() and
        # boolean test without wandering into a deep recursion path...
        $p = $p->numify() if ref($p) && $p->can('numify');
        if ((defined $p) && (int($p) != $p)) {
            Carp::croak('Argument to precision must be an integer');
        }
        if (ref($x)) {
            # $object->precision() or fallback to global
            $x->bfround($p) if $p; # not for undef, 0
            $x->{_p} = $p;         # set/overwrite, even if not rounded
            delete $x->{_a};       # clear A
            $p = ${"${class}::precision"} unless defined $p; # proper return value
        } else {
            ${"${class}::precision"} = $p; # set global P
            ${"${class}::accuracy"} = undef; # clear global A
        }
        return $p;              # shortcut
    }
404

405 406 407 408 409 410 411
    my $p;
    # $object->precision() or fallback to global
    $p = $x->{_p} if ref($x);
    # but don't return global undef, when $x's precision is 0!
    $p = ${"${class}::precision"} if !defined $p;
    $p;
}
412

413 414
sub config {
    # return (or set) configuration data as hash ref
415
    my $class = shift || __PACKAGE__;
416

417 418 419
    no strict 'refs';
    if (@_ > 1 || (@_ == 1 && (ref($_[0]) eq 'HASH'))) {
        # try to set given options as arguments from hash
420

421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449
        my $args = $_[0];
        if (ref($args) ne 'HASH') {
            $args = { @_ };
        }
        # these values can be "set"
        my $set_args = {};
        foreach my $key (qw/
                               accuracy precision
                               round_mode div_scale
                               upgrade downgrade
                               trap_inf trap_nan
                           /)
        {
            $set_args->{$key} = $args->{$key} if exists $args->{$key};
            delete $args->{$key};
        }
        if (keys %$args > 0) {
            Carp::croak("Illegal key(s) '", join("', '", keys %$args),
                        "' passed to $class\->config()");
        }
        foreach my $key (keys %$set_args) {
            if ($key =~ /^trap_(inf|nan)\z/) {
                ${"${class}::_trap_$1"} = ($set_args->{"trap_$1"} ? 1 : 0);
                next;
            }
            # use a call instead of just setting the $variable to check argument
            $class->$key($set_args->{$key});
        }
    }
450

451 452 453 454 455 456 457 458 459 460 461 462 463 464 465
    # now return actual configuration

    my $cfg = {
               lib         => $CALC,
               lib_version => ${"${CALC}::VERSION"},
               class       => $class,
               trap_nan    => ${"${class}::_trap_nan"},
               trap_inf    => ${"${class}::_trap_inf"},
               version     => ${"${class}::VERSION"},
              };
    foreach my $key (qw/
                           accuracy precision
                           round_mode div_scale
                           upgrade downgrade
                       /)
466
    {
467
        $cfg->{$key} = ${"${class}::$key"};
468
    }
469 470 471 472 473 474
    if (@_ == 1 && (ref($_[0]) ne 'HASH')) {
        # calls of the style config('lib') return just this value
        return $cfg->{$_[0]};
    }
    $cfg;
}
475

476 477 478 479
sub _scale_a {
    # select accuracy parameter based on precedence,
    # used by bround() and bfround(), may return undef for scale (means no op)
    my ($x, $scale, $mode) = @_;
480

481
    $scale = $x->{_a} unless defined $scale;
482

483 484
    no strict 'refs';
    my $class = ref($x);
485

486 487
    $scale = ${ $class . '::accuracy' } unless defined $scale;
    $mode = ${ $class . '::round_mode' } unless defined $mode;
488

489 490 491 492 493
    if (defined $scale) {
        $scale = $scale->can('numify') ? $scale->numify()
                                       : "$scale" if ref($scale);
        $scale = int($scale);
    }
494

495 496
    ($scale, $mode);
}
497

498 499 500 501
sub _scale_p {
    # select precision parameter based on precedence,
    # used by bround() and bfround(), may return undef for scale (means no op)
    my ($x, $scale, $mode) = @_;
502

503 504 505 506 507 508 509 510 511 512 513 514 515 516 517
    $scale = $x->{_p} unless defined $scale;

    no strict 'refs';
    my $class = ref($x);

    $scale = ${ $class . '::precision' } unless defined $scale;
    $mode = ${ $class . '::round_mode' } unless defined $mode;

    if (defined $scale) {
        $scale = $scale->can('numify') ? $scale->numify()
                                       : "$scale" if ref($scale);
        $scale = int($scale);
    }

    ($scale, $mode);
518
}
519

520 521 522 523
###############################################################################
# Constructor methods
###############################################################################

524 525 526
sub new {
    # Create a new Math::BigInt object from a string or another Math::BigInt
    # object. See hash keys documented at top.
527

528 529 530
    # The argument could be an object, so avoid ||, && etc. on it. This would
    # cause costly overloaded code to be called. The only allowed ops are ref()
    # and defined.
531

532 533 534
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;
535

536 537 538 539 540 541 542 543 544 545 546 547 548
    # The POD says:
    #
    # "Currently, Math::BigInt->new() defaults to 0, while Math::BigInt->new('')
    # results in 'NaN'. This might change in the future, so use always the
    # following explicit forms to get a zero or NaN:
    #     $zero = Math::BigInt->bzero();
    #     $nan = Math::BigInt->bnan();
    #
    # But although this use has been discouraged for more than 10 years, people
    # apparently still use it, so we still support it.

    return $self->bzero() unless @_;

549
    my ($wanted, $a, $p, $r) = @_;
550

551 552
    # Always return a new object, so it called as an instance method, copy the
    # invocand, and if called as a class method, initialize a new object.
553

554 555
    $self = $selfref ? $self -> copy()
                     : bless {}, $class;
556

557
    unless (defined $wanted) {
558
        #Carp::carp("Use of uninitialized value in new()");
559
        return $self->bzero($a, $p, $r);
560
    }
561 562 563 564 565 566 567 568

    if (ref($wanted) && $wanted->isa($class)) {         # MBI or subclass
        # Using "$copy = $wanted -> copy()" here fails some tests. Fixme!
        my $copy = $class -> copy($wanted);
        if ($selfref) {
            %$self = %$copy;
        } else {
            $self = $copy;
569
        }
570
        return $self;
571
    }
572 573 574 575 576 577 578 579 580 581 582 583 584

    $class->import() if $IMPORT == 0;           # make require work

    # Shortcut for non-zero scalar integers with no non-zero exponent.

    if (!ref($wanted) &&
        $wanted =~ / ^
                     ([+-]?)            # optional sign
                     ([1-9][0-9]*)      # non-zero significand
                     (\.0*)?            # ... with optional zero fraction
                     ([Ee][+-]?0+)?     # optional zero exponent
                     \z
                   /x)
585
    {
586 587 588 589 590 591 592 593 594
        my $sgn = $1;
        my $abs = $2;
        $self->{sign} = $sgn || '+';
        $self->{value} = $CALC->_new($abs);

        no strict 'refs';
        if (defined($a) || defined($p)
            || defined(${"${class}::precision"})
            || defined(${"${class}::accuracy"}))
595
        {
596
            $self->round($a, $p, $r)
597
              unless @_ >= 3 && !defined $a && !defined $p;
598
        }
599

600 601 602 603
        return $self;
    }

    # Handle Infs.
604

605 606 607
    if ($wanted =~ /^\s*([+-]?)inf(inity)?\s*\z/i) {
        my $sgn = $1 || '+';
        $self->{sign} = $sgn . 'inf';   # set a default sign for bstr()
608
        return $class->binf($sgn);
609 610 611 612 613
    }

    # Handle explicit NaNs (not the ones returned due to invalid input).

    if ($wanted =~ /^\s*([+-]?)nan\s*\z/i) {
614 615 616
        $self = $class -> bnan();
        $self->round($a, $p, $r) unless @_ >= 3 && !defined $a && !defined $p;
        return $self;
617 618
    }

619 620
    # Handle hexadecimal numbers.

621
    if ($wanted =~ /^\s*[+-]?0[Xx]/) {
622 623 624
        $self = $class -> from_hex($wanted);
        $self->round($a, $p, $r) unless @_ >= 3 && !defined $a && !defined $p;
        return $self;
625 626
    }

627 628
    # Handle binary numbers.

629
    if ($wanted =~ /^\s*[+-]?0[Bb]/) {
630 631 632
        $self = $class -> from_bin($wanted);
        $self->round($a, $p, $r) unless @_ >= 3 && !defined $a && !defined $p;
        return $self;
633 634 635 636 637 638
    }

    # Split string into mantissa, exponent, integer, fraction, value, and sign.
    my ($mis, $miv, $mfv, $es, $ev) = _split($wanted);
    if (!ref $mis) {
        if ($_trap_nan) {
639
            Carp::croak("$wanted is not a number in $class");
640 641
        }
        $self->{value} = $CALC->_zero();
642
        $self->{sign} = $nan;
643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661
        return $self;
    }

    if (!ref $miv) {
        # _from_hex or _from_bin
        $self->{value} = $mis->{value};
        $self->{sign} = $mis->{sign};
        return $self;   # throw away $mis
    }

    # Make integer from mantissa by adjusting exponent, then convert to a
    # Math::BigInt.
    $self->{sign} = $$mis;           # store sign
    $self->{value} = $CALC->_zero(); # for all the NaN cases
    my $e = int("$$es$$ev");         # exponent (avoid recursion)
    if ($e > 0) {
        my $diff = $e - CORE::length($$mfv);
        if ($diff < 0) {         # Not integer
            if ($_trap_nan) {
662
                Carp::croak("$wanted not an integer in $class");
663 664 665 666 667 668 669 670
            }
            #print "NOI 1\n";
            return $upgrade->new($wanted, $a, $p, $r) if defined $upgrade;
            $self->{sign} = $nan;
        } else {                 # diff >= 0
            # adjust fraction and add it to value
            #print "diff > 0 $$miv\n";
            $$miv = $$miv . ($$mfv . '0' x $diff);
671 672
        }
    }
673 674 675 676 677

    else {
        if ($$mfv ne '') {       # e <= 0
            # fraction and negative/zero E => NOI
            if ($_trap_nan) {
678
                Carp::croak("$wanted not an integer in $class");
679 680 681 682 683 684 685 686 687 688 689 690 691 692
            }
            #print "NOI 2 \$\$mfv '$$mfv'\n";
            return $upgrade->new($wanted, $a, $p, $r) if defined $upgrade;
            $self->{sign} = $nan;
        } elsif ($e < 0) {
            # xE-y, and empty mfv
            # Split the mantissa at the decimal point. E.g., if
            # $$miv = 12345 and $e = -2, then $frac = 45 and $$miv = 123.

            my $frac = substr($$miv, $e); # $frac is fraction part
            substr($$miv, $e) = "";       # $$miv is now integer part

            if ($frac =~ /[^0]/) {
                if ($_trap_nan) {
693
                    Carp::croak("$wanted not an integer in $class");
694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710
                }
                #print "NOI 3\n";
                return $upgrade->new($wanted, $a, $p, $r) if defined $upgrade;
                $self->{sign} = $nan;
            }
        }
    }

    unless ($self->{sign} eq $nan) {
        $self->{sign} = '+' if $$miv eq '0';            # normalize -0 => +0
        $self->{value} = $CALC->_new($$miv) if $self->{sign} =~ /^[+-]$/;
    }

    # If any of the globals are set, use them to round, and store them inside
    # $self. Do not round for new($x, undef, undef) since that is used by MBF
    # to signal no rounding.

711
    $self->round($a, $p, $r) unless @_ >= 3 && !defined $a && !defined $p;
712 713
    $self;
}
714

715
# Create a Math::BigInt from a hexadecimal string.
716

717
sub from_hex {
718
    my $self    = shift;
719
    my $selfref = ref $self;
720 721
    my $class   = $selfref || $self;

722 723 724 725
    # Don't modify constant (read-only) objects.

    return if $selfref && $self->modify('from_hex');

726
    my $str = shift;
727

728
    # If called as a class method, initialize a new object.
729

730
    $self = $class -> bzero() unless $selfref;
731

732 733 734 735 736 737 738 739 740 741 742 743 744
    if ($str =~ s/
                     ^
                     ( [+-]? )
                     (0?x)?
                     (
                         [0-9a-fA-F]*
                         ( _ [0-9a-fA-F]+ )*
                     )
                     $
                 //x)
    {
        # Get a "clean" version of the string, i.e., non-emtpy and with no
        # underscores or invalid characters.
745

746 747 748 749
        my $sign = $1;
        my $chrs = $3;
        $chrs =~ tr/_//d;
        $chrs = '0' unless CORE::length $chrs;
750

751
        # The library method requires a prefix.
752

753
        $self->{value} = $CALC->_from_hex('0x' . $chrs);
754

755
        # Place the sign.
756

757 758
        $self->{sign} = $sign eq '-' && ! $CALC->_is_zero($self->{value})
                          ? '-' : '+';
759

760 761
        return $self;
    }
762

763 764
    # CORE::hex() parses as much as it can, and ignores any trailing garbage.
    # For backwards compatibility, we return NaN.
765

766
    return $self->bnan();
767 768
}

769
# Create a Math::BigInt from an octal string.
770

771
sub from_oct {
772 773 774 775
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;

776 777 778 779
    # Don't modify constant (read-only) objects.

    return if $selfref && $self->modify('from_oct');

780
    my $str = shift;
781

782
    # If called as a class method, initialize a new object.
783

784
    $self = $class -> bzero() unless $selfref;
785

786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809
    if ($str =~ s/
                     ^
                     ( [+-]? )
                     (
                         [0-7]*
                         ( _ [0-7]+ )*
                     )
                     $
                 //x)
    {
        # Get a "clean" version of the string, i.e., non-emtpy and with no
        # underscores or invalid characters.

        my $sign = $1;
        my $chrs = $2;
        $chrs =~ tr/_//d;
        $chrs = '0' unless CORE::length $chrs;

        # The library method requires a prefix.

        $self->{value} = $CALC->_from_oct('0' . $chrs);

        # Place the sign.

810 811
        $self->{sign} = $sign eq '-' && ! $CALC->_is_zero($self->{value})
                          ? '-' : '+';
812 813

        return $self;
814 815
    }

816 817
    # CORE::oct() parses as much as it can, and ignores any trailing garbage.
    # For backwards compatibility, we return NaN.
818

819 820
    return $self->bnan();
}
821

822
# Create a Math::BigInt from a binary string.
823

824
sub from_bin {
825 826 827 828
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;

829 830 831 832
    # Don't modify constant (read-only) objects.

    return if $selfref && $self->modify('from_bin');

833
    my $str = shift;
834

835
    # If called as a class method, initialize a new object.
836

837
    $self = $class -> bzero() unless $selfref;
838

839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863
    if ($str =~ s/
                     ^
                     ( [+-]? )
                     (0?b)?
                     (
                         [01]*
                         ( _ [01]+ )*
                     )
                     $
                 //x)
    {
        # Get a "clean" version of the string, i.e., non-emtpy and with no
        # underscores or invalid characters.

        my $sign = $1;
        my $chrs = $3;
        $chrs =~ tr/_//d;
        $chrs = '0' unless CORE::length $chrs;

        # The library method requires a prefix.

        $self->{value} = $CALC->_from_bin('0b' . $chrs);

        # Place the sign.

864 865
        $self->{sign} = $sign eq '-' && ! $CALC->_is_zero($self->{value})
                          ? '-' : '+';
866 867 868 869 870 871 872 873 874 875

        return $self;
    }

    # For consistency with from_hex() and from_oct(), we return NaN when the
    # input is invalid.

    return $self->bnan();
}

876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896
# Create a Math::BigInt from a byte string.

sub from_bytes {
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;

    # Don't modify constant (read-only) objects.

    return if $selfref && $self->modify('from_bytes');

    my $str = shift;

    # If called as a class method, initialize a new object.

    $self = $class -> bzero() unless $selfref;
    $self -> {sign}  = '+';
    $self -> {value} = $CALC -> _from_bytes($str);
    return $self;
}

897 898 899 900 901 902 903 904 905 906 907 908 909 910
sub bzero {
    # create/assign '+0'

    if (@_ == 0) {
        #Carp::carp("Using bzero() as a function is deprecated;",
        #           " use bzero() as a method instead");
        unshift @_, __PACKAGE__;
    }

    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;

    $self->import() if $IMPORT == 0;            # make require work
911 912 913

    # Don't modify constant (read-only) objects.

914
    return if $selfref && $self->modify('bzero');
915 916 917 918 919

    $self = bless {}, $class unless $selfref;

    $self->{sign} = '+';
    $self->{value} = $CALC->_zero();
920 921 922

    if (@_ > 0) {
        if (@_ > 3) {
923 924
            # call like: $x->bzero($a, $p, $r, $y, ...);
            ($self, $self->{_a}, $self->{_p}) = $self->_find_round_parameters(@_);
925
        } else {
926
            # call like: $x->bzero($a, $p, $r);
927 928 929 930 931
            $self->{_a} = $_[0]
              if !defined $self->{_a} || (defined $_[0] && $_[0] > $self->{_a});
            $self->{_p} = $_[1]
              if !defined $self->{_p} || (defined $_[1] && $_[1] > $self->{_p});
        }
932
    }
933 934 935

    return $self;
}
936

937 938
sub bone {
    # Create or assign '+1' (or -1 if given sign '-').
939

940 941 942 943 944
    if (@_ == 0 || (defined($_[0]) && ($_[0] eq '+' || $_[0] eq '-'))) {
        #Carp::carp("Using bone() as a function is deprecated;",
        #           " use bone() as a method instead");
        unshift @_, __PACKAGE__;
    }
945

946 947 948 949 950
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;

    $self->import() if $IMPORT == 0;            # make require work
951 952 953

    # Don't modify constant (read-only) objects.

954
    return if $selfref && $self->modify('bone');
955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974

    my $sign = shift;
    $sign = defined $sign && $sign =~ /^\s*-/ ? "-" : "+";

    $self = bless {}, $class unless $selfref;

    $self->{sign}  = $sign;
    $self->{value} = $CALC->_one();

    if (@_ > 0) {
        if (@_ > 3) {
            # call like: $x->bone($sign, $a, $p, $r, $y, ...);
            ($self, $self->{_a}, $self->{_p}) = $self->_find_round_parameters(@_);
        } else {
            # call like: $x->bone($sign, $a, $p, $r);
            $self->{_a} = $_[0]
              if !defined $self->{_a} || (defined $_[0] && $_[0] > $self->{_a});
            $self->{_p} = $_[1]
              if !defined $self->{_p} || (defined $_[1] && $_[1] > $self->{_p});
        }
975 976
    }

977 978 979 980 981
    return $self;
}

sub binf {
    # create/assign a '+inf' or '-inf'
982

983 984
    if (@_ == 0 || (defined($_[0]) && !ref($_[0]) &&
                    $_[0] =~ /^\s*[+-](inf(inity)?)?\s*$/))
985
    {
986 987 988 989
        #Carp::carp("Using binf() as a function is deprecated;",
        #           " use binf() as a method instead");
        unshift @_, __PACKAGE__;
    }
990

991 992 993
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;
994

995 996 997 998 999 1000
    {
        no strict 'refs';
        if (${"${class}::_trap_inf"}) {
            Carp::croak("Tried to create +-inf in $class->binf()");
        }
    }
1001

1002
    $self->import() if $IMPORT == 0;            # make require work
1003 1004 1005

    # Don't modify constant (read-only) objects.

1006
    return if $selfref && $self->modify('binf');
1007

1008 1009
    my $sign = shift;
    $sign = defined $sign && $sign =~ /^\s*-/ ? "-" : "+";
1010

1011
    $self = bless {}, $class unless $selfref;
1012

1013 1014
    $self -> {sign}  = $sign . 'inf';
    $self -> {value} = $CALC -> _zero();
1015

1016 1017
    return $self;
}
1018

1019 1020
sub bnan {
    # create/assign a 'NaN'
1021

1022 1023 1024 1025 1026
    if (@_ == 0) {
        #Carp::carp("Using bnan() as a function is deprecated;",
        #           " use bnan() as a method instead");
        unshift @_, __PACKAGE__;
    }
1027

1028 1029 1030
    my $self    = shift;
    my $selfref = ref($self);
    my $class   = $selfref || $self;
1031

1032 1033 1034 1035
    {
        no strict 'refs';
        if (${"${class}::_trap_nan"}) {
            Carp::croak("Tried to create NaN in $class->bnan()");
1036
        }
1037 1038
    }

1039
    $self->import() if $IMPORT == 0;            # make require work
1040 1041 1042

    # Don't modify constant (read-only) objects.

1043
    return if $selfref && $self->modify('bnan');
1044

1045
    $self = bless {}, $class unless $selfref;
1046

1047 1048
    $self -> {sign}  = $nan;
    $self -> {value} = $CALC -> _zero();
1049

1050 1051
    return $self;
}
1052

1053 1054 1055 1056 1057 1058 1059 1060
sub bpi {
    # Calculate PI to N digits. Unless upgrading is in effect, returns the
    # result truncated to an integer, that is, always returns '3'.
    my ($self, $n) = @_;
    if (@_ == 1) {
        # called like Math::BigInt::bpi(10);
        $n = $self;
        $self = $class;
1061
    }
1062
    $self = ref($self) if ref($self);
1063

1064
    return $upgrade->new($n) if defined $upgrade;
1065

1066 1067
    # hard-wired to "3"
    $self->new(3);
1068
}
1069

1070 1071 1072 1073
sub copy {
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;
1074

1075
    # If called as a class method, the object to copy is the next argument.
1076

1077
    $self = shift() unless $selfref;
1078

1079
    my $copy = bless {}, $class;
1080

1081 1082 1083 1084
    $copy->{sign}  = $self->{sign};
    $copy->{value} = $CALC->_copy($self->{value});
    $copy->{_a}    = $self->{_a} if exists $self->{_a};
    $copy->{_p}    = $self->{_p} if exists $self->{_p};
1085

1086 1087
    return $copy;
}
1088

1089 1090 1091 1092 1093 1094
sub as_number {
    # An object might be asked to return itself as bigint on certain overloaded
    # operations. This does exactly this, so that sub classes can simple inherit
    # it or override with their own integer conversion routine.
    $_[0]->copy();
}
1095

1096 1097 1098
###############################################################################
# Boolean methods
###############################################################################
1099

1100 1101 1102
sub is_zero {
    # return true if arg (BINT or num_str) is zero (array '+', '0')
    my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
1103

1104 1105 1106
    return 0 if $x->{sign} !~ /^\+$/; # -, NaN & +-inf aren't
    $CALC->_is_zero($x->{value});
}
1107

1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130
sub is_one {
    # return true if arg (BINT or num_str) is +1, or -1 if sign is given
    my ($class, $x, $sign) = ref($_[0]) ? (undef, @_) : objectify(1, @_);

    $sign = '+' if !defined $sign || $sign ne '-';

    return 0 if $x->{sign} ne $sign; # -1 != +1, NaN, +-inf aren't either
    $CALC->_is_one($x->{value});
}

sub is_finite {
    my $x = shift;
    return $x->{sign} eq '+' || $x->{sign} eq '-';
}

sub is_inf {
    # return true if arg (BINT or num_str) is +-inf
    my ($class, $x, $sign) = ref($_[0]) ? (undef, @_) : objectify(1, @_);

    if (defined $sign) {
        $sign = '[+-]inf' if $sign eq ''; # +- doesn't matter, only that's inf
        $sign = "[$1]inf" if $sign =~ /^([+-])(inf)?$/; # extract '+' or '-'
        return $x->{sign} =~ /^$sign$/ ? 1 : 0;
1131
    }
1132 1133
    $x->{sign} =~ /^[+-]inf$/ ? 1 : 0; # only +-inf is infinity
}
1134

1135 1136 1137 1138 1139
sub is_nan {
    # return true if arg (BINT or num_str) is NaN
    my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);

    $x->{sign} eq $nan ? 1 : 0;
1140
}
1141

1142 1143 1144
sub is_positive {
    # return true when arg (BINT or num_str) is positive (> 0)
    my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
1145

1146
    return 1 if $x->{sign} eq '+inf'; # +inf is positive
1147

1148 1149 1150
    # 0+ is neither positive nor negative
    ($x->{sign} eq '+' && !$x->is_zero()) ? 1 : 0;
}
1151

1152 1153 1154
sub is_negative {
    # return true when arg (BINT or num_str) is negative (< 0)
    my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
1155

1156
    $x->{sign} =~ /^-/ ? 1 : 0; # -inf is negative, but NaN is not
1157 1158
}

1159 1160 1161
sub is_odd {
    # return true when arg (BINT or num_str) is odd, false for even
    my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
1162

1163 1164 1165
    return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't
    $CALC->_is_odd($x->{value});
}
1166

1167 1168 1169
sub is_even {
    # return true when arg (BINT or num_str) is even, false for odd
    my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
1170

1171 1172 1173
    return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't
    $CALC->_is_even($x->{value});
}
1174

1175 1176 1177 1178
sub is_int {
    # return true when arg (BINT or num_str) is an integer
    # always true for Math::BigInt, but different for Math::BigFloat objects
    my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
1179

1180 1181
    $x->{sign} =~ /^[+-]$/ ? 1 : 0; # inf/-inf/NaN aren't
}
1182

1183 1184 1185
###############################################################################
# Comparison methods
###############################################################################
1186

1187 1188 1189
sub bcmp {
    # Compares 2 values.  Returns one of undef, <0, =0, >0. (suitable for sort)
    # (BINT or num_str, BINT or num_str) return cond_code
1190

1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224
    # set up parameters
    my ($class, $x, $y) = ref($_[0]) && ref($_[0]) eq ref($_[1])
                        ? (ref($_[0]), @_)
                        : objectify(2, @_);

    return $upgrade->bcmp($x, $y) if defined $upgrade &&
      ((!$x->isa($class)) || (!$y->isa($class)));

    if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/)) {
        # handle +-inf and NaN
        return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
        return 0 if $x->{sign} eq $y->{sign} && $x->{sign} =~ /^[+-]inf$/;
        return +1 if $x->{sign} eq '+inf';
        return -1 if $x->{sign} eq '-inf';
        return -1 if $y->{sign} eq '+inf';
        return +1;
    }
    # check sign for speed first
    return 1 if $x->{sign} eq '+' && $y->{sign} eq '-'; # does also 0 <=> -y
    return -1 if $x->{sign} eq '-' && $y->{sign} eq '+'; # does also -x <=> 0

    # have same sign, so compare absolute values.  Don't make tests for zero
    # here because it's actually slower than testing in Calc (especially w/ Pari
    # et al)

    # post-normalized compare for internal use (honors signs)
    if ($x->{sign} eq '+') {
        # $x and $y both > 0
        return $CALC->_acmp($x->{value}, $y->{value});
    }

    # $x && $y both < 0
    $CALC->_acmp($y->{value}, $x->{value}); # swapped acmp (lib returns 0, 1, -1)
}
1225

1226 1227 1228 1229
sub bacmp {
    # Compares 2 values, ignoring their signs.
    # Returns one of undef, <0, =0, >0. (suitable for sort)
    # (BINT, BINT) return cond_code
1230

1231 1232 1233 1234
    # set up parameters
    my ($class, $x, $y) = ref($_[0]) && ref($_[0]) eq ref($_[1])
                        ? (ref($_[0]), @_)
                        : objectify(2, @_);
1235

1236 1237
    return $upgrade->bacmp($x, $y) if defined $upgrade &&
      ((!$x->isa($class)) || (!$y->isa($class)));
1238

1239 1240 1241 1242 1243 1244
    if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/)) {
        # handle +-inf and NaN
        return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
        return 0 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} =~ /^[+-]inf$/;
        return 1 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} !~ /^[+-]inf$/;
        return -1;
1245
    }
1246 1247
    $CALC->_acmp($x->{value}, $y->{value}); # lib does only 0, 1, -1
}
1248

1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317
sub beq {
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;

    Carp::croak 'beq() is an instance method, not a class method' unless $selfref;
    Carp::croak 'Wrong number of arguments for beq()' unless @_ == 1;

    my $cmp = $self -> bcmp(shift);
    return defined($cmp) && ! $cmp;
}

sub bne {
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;

    Carp::croak 'bne() is an instance method, not a class method' unless $selfref;
    Carp::croak 'Wrong number of arguments for bne()' unless @_ == 1;

    my $cmp = $self -> bcmp(shift);
    return defined($cmp) && ! $cmp ? '' : 1;
}

sub blt {
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;

    Carp::croak 'blt() is an instance method, not a class method' unless $selfref;
    Carp::croak 'Wrong number of arguments for blt()' unless @_ == 1;

    my $cmp = $self -> bcmp(shift);
    return defined($cmp) && $cmp < 0;
}

sub ble {
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;

    Carp::croak 'ble() is an instance method, not a class method' unless $selfref;
    Carp::croak 'Wrong number of arguments for ble()' unless @_ == 1;

    my $cmp = $self -> bcmp(shift);
    return defined($cmp) && $cmp <= 0;
}

sub bgt {
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;

    Carp::croak 'bgt() is an instance method, not a class method' unless $selfref;
    Carp::croak 'Wrong number of arguments for bgt()' unless @_ == 1;

    my $cmp = $self -> bcmp(shift);
    return defined($cmp) && $cmp > 0;
}

sub bge {
    my $self    = shift;
    my $selfref = ref $self;
    my $class   = $selfref || $self;

    Carp::croak 'bge() is an instance method, not a class method'
        unless $selfref;
    Carp::croak 'Wrong number of arguments for bge()' unless @_ == 1;

1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406
    my $cmp = $self -> bcmp(shift);
    return defined($cmp) && $cmp >= 0;
}

###############################################################################
# Arithmetic methods
###############################################################################

sub bneg {
    # (BINT or num_str) return BINT
    # negate number or make a negated number from string
    my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);

    return $x if $x->modify('bneg');

    # for +0 do not negate (to have always normalized +0). Does nothing for 'NaN'
    $x->{sign} =~ tr/+-/-+/ unless ($x->{sign} eq '+' && $CALC->_is_zero($x->{value}));
    $x;
}

sub babs {
    # (BINT or num_str) return BINT
    # make number absolute, or return absolute BINT from string
    my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);

    return $x if $x->modify('babs');
    # post-normalized abs for internal use (does nothing for NaN)
    $x->{sign} =~ s/^-/+/;
    $x;
}

sub bsgn {
    # Signum function.

    my $self = shift;

    return $self if $self->modify('bsgn');

    return $self -> bone("+") if $self -> is_pos();
    return $self -> bone("-") if $self -> is_neg();
    return $self;               # zero or NaN
}

sub bnorm {
    # (numstr or BINT) return BINT
    # Normalize number -- no-op here
    my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
    $x;
}

sub binc {
    # increment arg by one
    my ($class, $x, $a, $p, $r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_);
    return $x if $x->modify('binc');

    if ($x->{sign} eq '+') {
        $x->{value} = $CALC->_inc($x->{value});
        return $x->round($a, $p, $r);
    } elsif ($x->{sign} eq '-') {
        $x->{value} = $CALC->_dec($x->{value});
        $x->{sign} = '+' if $CALC->_is_zero($x->{value}); # -1 +1 => -0 => +0
        return $x->round($a, $p, $r);
    }
    # inf, nan handling etc
    $x->badd($class->bone(), $a, $p, $r); # badd does round
}

sub bdec {
    # decrement arg by one
    my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_);
    return $x if $x->modify('bdec');

    if ($x->{sign} eq '-') {
        # x already < 0
        $x->{value} = $CALC->_inc($x->{value});
    } else {
        return $x->badd($class->bone('-'), @r)
          unless $x->{sign} eq '+'; # inf or NaN
        # >= 0
        if ($CALC->_is_zero($x->{value})) {
            # == 0
            $x->{value} = $CALC->_one();
            $x->{sign} = '-'; # 0 => -1
        } else {
            # > 0
            $x->{value} = $CALC->_dec($x->{value});
        }
    }
    $x->round(@r);
1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498
}

#sub bstrcmp {
#    my $self    = shift;
#    my $selfref = ref $self;
#    my $class   = $selfref || $self;
#
#    Carp::croak 'bstrcmp() is an instance method, not a class method'
#        unless $selfref;
#    Carp::croak 'Wrong number of arguments for bstrcmp()' unless @_ == 1;
#
#    return $self -> bstr() CORE::cmp shift;
#}
#
#sub bstreq {
#    my $self    = shift;
#    my $selfref = ref $self;
#    my $class   = $selfref || $self;
#
#    Carp::croak 'bstreq() is an instance method, not a class method'
#        unless $selfref;
#    Carp::croak 'Wrong number of arguments for bstreq()' unless @_ == 1;
#
#    my $cmp = $self -> bstrcmp(shift);
#    return defined($cmp) && ! $cmp;
#}
#
#sub bstrne {
#    my $self    = shift;
#    my $selfref = ref $self;
#    my $class   = $selfref || $self;
#
#    Carp::croak 'bstrne() is an instance method, not a class method'
#        unless $selfref;
#    Carp::croak 'Wrong number of arguments for bstrne()' unless @_ == 1;
#
#    my $cmp = $self -> bstrcmp(shift);
#    return defined($cmp) && ! $cmp ? '' : 1;
#}
#
#sub bstrlt {
#    my $self    = shift;
#    my $selfref = ref $self;
#    my $class   = $selfref || $self;
#
#    Carp::croak 'bstrlt() is an instance method, not a class method'
#        unless $selfref;
#    Carp::croak 'Wrong number of arguments for bstrlt()' unless @_ == 1;
#
#    my $cmp = $self -> bstrcmp(shift);
#    return defined($cmp) && $cmp < 0;
#}
#
#sub bstrle {
#    my $self    = shift;
#    my $selfref = ref $self;
#    my $class   = $selfref || $self;
#
#    Carp::croak 'bstrle() is an instance method, not a class method'
#        unless $selfref;
#    Carp::croak 'Wrong number of arguments for bstrle()' unless @_ == 1;
#
#    my $cmp = $self -> bstrcmp(shift);
#    return defined($cmp) && $cmp <= 0;
#}
#
#sub bstrgt {
#    my $self    = shift;
#    my $selfref = ref $self;
#    my $class   = $selfref || $self;
#
#    Carp::croak 'bstrgt() is an instance method, not a class method'
#        unless $selfref;
#    Carp::croak 'Wrong number of arguments for bstrgt()' unless @_ == 1;
#
#    my $cmp = $self -> bstrcmp(shift);
#    return defined($cmp) && $cmp > 0;
#}
#
#sub bstrge {
#    my $self    = shift;
#    my $selfref = ref $self;
#    my $class   = $selfref || $self;
#
#    Carp::croak 'bstrge() is an instance method, not a class method'
#        unless $selfref;
#    Carp::croak 'Wrong number of arguments for bstrge()' unless @_ == 1;
#
#    my $cmp = $self -> bstrcmp(shift);
#    return defined($cmp) && $cmp >= 0;
#}

1499 1500 1501
sub badd {
    # add second arg (BINT or string) to first (BINT) (modifies first)
    # return result as BINT
1502

1503 1504 1505 1506 1507
    # set up parameters
    my ($class, $x, $y, @r) = (ref($_[0]), @_);
    # objectify is costly, so avoid it
    if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
        ($class, $x, $y, @r) = objectify(2, @_);
1508 1509
    }

1510 1511 1512
    return $x if $x->modify('badd');
    return $upgrade->badd($upgrade->new($x), $upgrade->new($y), @r) if defined $upgrade &&
      ((!$x->isa($class)) || (!$y->isa($class)));
1513

1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528
    $r[3] = $y;                 # no push!
    # inf and NaN handling
    if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/) {
        # NaN first
        return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
        # inf handling
        if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/)) {
            # +inf++inf or -inf+-inf => same, rest is NaN
            return $x if $x->{sign} eq $y->{sign};
            return $x->bnan();
        }
        # +-inf + something => +inf
        # something +-inf => +-inf
        $x->{sign} = $y->{sign}, return $x if $y->{sign} =~ /^[+-]inf$/;
        return $x;
1529
    }
1530

1531
    my ($sx, $sy) = ($x->{sign}, $y->{sign});  # get signs
1532

1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547
    if ($sx eq $sy) {
        $x->{value} = $CALC->_add($x->{value}, $y->{value}); # same sign, abs add
    } else {
        my $a = $CALC->_acmp ($y->{value}, $x->{value}); # absolute compare
        if ($a > 0) {
            $x->{value} = $CALC->_sub($y->{value}, $x->{value}, 1); # abs sub w/ swap
            $x->{sign} = $sy;
        } elsif ($a == 0) {
            # speedup, if equal, set result to 0
            $x->{value} = $CALC->_zero();
            $x->{sign} = '+';
        } else                  # a < 0
        {
            $x->{value} = $CALC->_sub($x->{value}, $y->{value}); # abs sub
        }
1548
    }
1549 1550
    $x->round(@r);
}
1551

1552 1553 1554
sub bsub {
    # (BINT or num_str, BINT or num_str) return BINT
    # subtract second arg from first, modify first
1555

1556
    # set up parameters
1557
    my ($class, $x, $y, @r) = (ref($_[0]), @_);
1558

1559 1560
    # objectify is costly, so avoid it
    if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
1561
        ($class, $x, $y, @r) = objectify(2, @_);
1562 1563
    }

1564
    return $x if $x -> modify('bsub');
1565

1566
    return $upgrade -> new($x) -> bsub($upgrade -> new($y), @r)
1567
      if defined $upgrade && (!$x -> isa($class) || !$y -> isa($class));
1568

1569
    return $x -> round(@r) if $y -> is_zero();
1570

1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585
    # To correctly handle the lone special case $x -> bsub($x), we note the
    # sign of $x, then flip the sign from $y, and if the sign of $x did change,
    # too, then we caught the special case:

    my $xsign = $x -> {sign};
    $y -> {sign} =~ tr/+-/-+/;  # does nothing for NaN
    if ($xsign ne $x -> {sign}) {
        # special case of $x -> bsub($x) results in 0
        return $x -> bzero(@r) if $xsign =~ /^[+-]$/;
        return $x -> bnan();    # NaN, -inf, +inf
    }
    $x -> badd($y, @r);         # badd does not leave internal zeros
    $y -> {sign} =~ tr/+-/-+/;  # refix $y (does nothing for NaN)
    $x;                         # already rounded by badd() or no rounding
}
1586

1587 1588 1589
sub bmul {
    # multiply the first number by the second number
    # (BINT or num_str, BINT or num_str) return BINT
1590

1591 1592 1593 1594 1595
    # set up parameters
    my ($class, $x, $y, @r) = (ref($_[0]), @_);
    # objectify is costly, so avoid it
    if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
        ($class, $x, $y, @r) = objectify(2, @_);
1596 1597
    }

1598
    return $x if $x->modify('bmul');
1599