1N/A#!/usr/bin/perl -w
1N/A
1N/A# test inf/NaN handling all in one place
1N/A# Thanx to Jarkko for the excellent explanations and the tables
1N/A
1N/Ause Test;
1N/Ause strict;
1N/A
1N/ABEGIN
1N/A {
1N/A chdir 't' if -d 't';
1N/A unshift @INC, '../lib';
1N/A }
1N/ABEGIN
1N/A {
1N/A $| = 1;
1N/A # to locate the testing files
1N/A my $location = $0; $location =~ s/inf_nan.t//i;
1N/A if ($ENV{PERL_CORE})
1N/A {
1N/A @INC = qw(../t/lib); # testing with the core distribution
1N/A }
1N/A unshift @INC, '../lib'; # for testing manually
1N/A if (-d 't')
1N/A {
1N/A chdir 't';
1N/A require File::Spec;
1N/A unshift @INC, File::Spec->catdir(File::Spec->updir, $location);
1N/A }
1N/A else
1N/A {
1N/A unshift @INC, $location;
1N/A }
1N/A print "# INC = @INC\n";
1N/A
1N/A # values groups operators classes tests
1N/A plan tests => 7 * 6 * 5 * 4 * 2 +
1N/A 7 * 6 * 2 * 4 * 1; # bmod
1N/A }
1N/A
1N/Ause Math::BigInt;
1N/Ause Math::BigFloat;
1N/Ause Math::BigInt::Subclass;
1N/Ause Math::BigFloat::Subclass;
1N/A
1N/Amy @classes =
1N/A qw/Math::BigInt Math::BigFloat
1N/A Math::BigInt::Subclass Math::BigFloat::Subclass
1N/A /;
1N/A
1N/Amy (@args,$x,$y,$z);
1N/A
1N/A# +
1N/Aforeach (qw/
1N/A -inf:-inf:-inf
1N/A -1:-inf:-inf
1N/A -0:-inf:-inf
1N/A 0:-inf:-inf
1N/A 1:-inf:-inf
1N/A inf:-inf:NaN
1N/A NaN:-inf:NaN
1N/A
1N/A -inf:-1:-inf
1N/A -1:-1:-2
1N/A -0:-1:-1
1N/A 0:-1:-1
1N/A 1:-1:0
1N/A inf:-1:inf
1N/A NaN:-1:NaN
1N/A
1N/A -inf:0:-inf
1N/A -1:0:-1
1N/A -0:0:0
1N/A 0:0:0
1N/A 1:0:1
1N/A inf:0:inf
1N/A NaN:0:NaN
1N/A
1N/A -inf:1:-inf
1N/A -1:1:0
1N/A -0:1:1
1N/A 0:1:1
1N/A 1:1:2
1N/A inf:1:inf
1N/A NaN:1:NaN
1N/A
1N/A -inf:inf:NaN
1N/A -1:inf:inf
1N/A -0:inf:inf
1N/A 0:inf:inf
1N/A 1:inf:inf
1N/A inf:inf:inf
1N/A NaN:inf:NaN
1N/A
1N/A -inf:NaN:NaN
1N/A -1:NaN:NaN
1N/A -0:NaN:NaN
1N/A 0:NaN:NaN
1N/A 1:NaN:NaN
1N/A inf:NaN:NaN
1N/A NaN:NaN:NaN
1N/A /)
1N/A {
1N/A @args = split /:/,$_;
1N/A for my $class (@classes)
1N/A {
1N/A $x = $class->new($args[0]);
1N/A $y = $class->new($args[1]);
1N/A $args[2] = '0' if $args[2] eq '-0'; # BigInt/Float hasn't got -0
1N/A my $r = $x->badd($y);
1N/A
1N/A print "# x $class $args[0] + $args[1] should be $args[2] but is $x\n",
1N/A if !ok ($x->bstr(),$args[2]);
1N/A print "# r $class $args[0] + $args[1] should be $args[2] but is $r\n",
1N/A if !ok ($x->bstr(),$args[2]);
1N/A }
1N/A }
1N/A
1N/A# -
1N/Aforeach (qw/
1N/A -inf:-inf:NaN
1N/A -1:-inf:inf
1N/A -0:-inf:inf
1N/A 0:-inf:inf
1N/A 1:-inf:inf
1N/A inf:-inf:inf
1N/A NaN:-inf:NaN
1N/A
1N/A -inf:-1:-inf
1N/A -1:-1:0
1N/A -0:-1:1
1N/A 0:-1:1
1N/A 1:-1:2
1N/A inf:-1:inf
1N/A NaN:-1:NaN
1N/A
1N/A -inf:0:-inf
1N/A -1:0:-1
1N/A -0:0:-0
1N/A 0:0:0
1N/A 1:0:1
1N/A inf:0:inf
1N/A NaN:0:NaN
1N/A
1N/A -inf:1:-inf
1N/A -1:1:-2
1N/A -0:1:-1
1N/A 0:1:-1
1N/A 1:1:0
1N/A inf:1:inf
1N/A NaN:1:NaN
1N/A
1N/A -inf:inf:-inf
1N/A -1:inf:-inf
1N/A -0:inf:-inf
1N/A 0:inf:-inf
1N/A 1:inf:-inf
1N/A inf:inf:NaN
1N/A NaN:inf:NaN
1N/A
1N/A -inf:NaN:NaN
1N/A -1:NaN:NaN
1N/A -0:NaN:NaN
1N/A 0:NaN:NaN
1N/A 1:NaN:NaN
1N/A inf:NaN:NaN
1N/A NaN:NaN:NaN
1N/A /)
1N/A {
1N/A @args = split /:/,$_;
1N/A for my $class (@classes)
1N/A {
1N/A $x = $class->new($args[0]);
1N/A $y = $class->new($args[1]);
1N/A $args[2] = '0' if $args[2] eq '-0'; # BigInt/Float hasn't got -0
1N/A my $r = $x->bsub($y);
1N/A
1N/A print "# x $class $args[0] - $args[1] should be $args[2] but is $x\n"
1N/A if !ok ($x->bstr(),$args[2]);
1N/A print "# r $class $args[0] - $args[1] should be $args[2] but is $r\n"
1N/A if !ok ($r->bstr(),$args[2]);
1N/A }
1N/A }
1N/A
1N/A# *
1N/Aforeach (qw/
1N/A -inf:-inf:inf
1N/A -1:-inf:inf
1N/A -0:-inf:NaN
1N/A 0:-inf:NaN
1N/A 1:-inf:-inf
1N/A inf:-inf:-inf
1N/A NaN:-inf:NaN
1N/A
1N/A -inf:-1:inf
1N/A -1:-1:1
1N/A -0:-1:0
1N/A 0:-1:-0
1N/A 1:-1:-1
1N/A inf:-1:-inf
1N/A NaN:-1:NaN
1N/A
1N/A -inf:0:NaN
1N/A -1:0:-0
1N/A -0:0:-0
1N/A 0:0:0
1N/A 1:0:0
1N/A inf:0:NaN
1N/A NaN:0:NaN
1N/A
1N/A -inf:1:-inf
1N/A -1:1:-1
1N/A -0:1:-0
1N/A 0:1:0
1N/A 1:1:1
1N/A inf:1:inf
1N/A NaN:1:NaN
1N/A
1N/A -inf:inf:-inf
1N/A -1:inf:-inf
1N/A -0:inf:NaN
1N/A 0:inf:NaN
1N/A 1:inf:inf
1N/A inf:inf:inf
1N/A NaN:inf:NaN
1N/A
1N/A -inf:NaN:NaN
1N/A -1:NaN:NaN
1N/A -0:NaN:NaN
1N/A 0:NaN:NaN
1N/A 1:NaN:NaN
1N/A inf:NaN:NaN
1N/A NaN:NaN:NaN
1N/A /)
1N/A {
1N/A @args = split /:/,$_;
1N/A for my $class (@classes)
1N/A {
1N/A $x = $class->new($args[0]);
1N/A $y = $class->new($args[1]);
1N/A $args[2] = '0' if $args[2] eq '-0'; # BigInt/Float hasn't got -0
1N/A $args[2] = '0' if $args[2] eq '-0'; # BigInt hasn't got -0
1N/A my $r = $x->bmul($y);
1N/A
1N/A print "# x $class $args[0] * $args[1] should be $args[2] but is $x\n"
1N/A if !ok ($x->bstr(),$args[2]);
1N/A print "# r $class $args[0] * $args[1] should be $args[2] but is $r\n"
1N/A if !ok ($r->bstr(),$args[2]);
1N/A }
1N/A }
1N/A
1N/A# /
1N/Aforeach (qw/
1N/A -inf:-inf:NaN
1N/A -1:-inf:0
1N/A -0:-inf:0
1N/A 0:-inf:-0
1N/A 1:-inf:-0
1N/A inf:-inf:NaN
1N/A NaN:-inf:NaN
1N/A
1N/A -inf:-1:inf
1N/A -1:-1:1
1N/A -0:-1:0
1N/A 0:-1:-0
1N/A 1:-1:-1
1N/A inf:-1:-inf
1N/A NaN:-1:NaN
1N/A
1N/A -inf:0:-inf
1N/A -1:0:-inf
1N/A -0:0:NaN
1N/A 0:0:NaN
1N/A 1:0:inf
1N/A inf:0:inf
1N/A NaN:0:NaN
1N/A
1N/A -inf:1:-inf
1N/A -1:1:-1
1N/A -0:1:-0
1N/A 0:1:0
1N/A 1:1:1
1N/A inf:1:inf
1N/A NaN:1:NaN
1N/A
1N/A -inf:inf:NaN
1N/A -1:inf:-0
1N/A -0:inf:-0
1N/A 0:inf:0
1N/A 1:inf:0
1N/A inf:inf:NaN
1N/A NaN:inf:NaN
1N/A
1N/A -inf:NaN:NaN
1N/A -1:NaN:NaN
1N/A -0:NaN:NaN
1N/A 0:NaN:NaN
1N/A 1:NaN:NaN
1N/A inf:NaN:NaN
1N/A NaN:NaN:NaN
1N/A /)
1N/A {
1N/A @args = split /:/,$_;
1N/A for my $class (@classes)
1N/A {
1N/A $x = $class->new($args[0]);
1N/A $y = $class->new($args[1]);
1N/A $args[2] = '0' if $args[2] eq '-0'; # BigInt/Float hasn't got -0
1N/A
1N/A my $t = $x->copy();
1N/A my $tmod = $t->copy();
1N/A
1N/A # bdiv in scalar context
1N/A my $r = $x->bdiv($y);
1N/A print "# x $class $args[0] / $args[1] should be $args[2] but is $x\n"
1N/A if !ok ($x->bstr(),$args[2]);
1N/A print "# r $class $args[0] / $args[1] should be $args[2] but is $r\n"
1N/A if !ok ($r->bstr(),$args[2]);
1N/A
1N/A # bmod and bdiv in list context
1N/A my ($d,$rem) = $t->bdiv($y);
1N/A
1N/A # bdiv in list context
1N/A print "# t $class $args[0] / $args[1] should be $args[2] but is $t\n"
1N/A if !ok ($t->bstr(),$args[2]);
1N/A print "# d $class $args[0] / $args[1] should be $args[2] but is $d\n"
1N/A if !ok ($d->bstr(),$args[2]);
1N/A
1N/A # bmod
1N/A my $m = $tmod->bmod($y);
1N/A
1N/A # bmod() agrees with bdiv?
1N/A print "# m $class $args[0] % $args[1] should be $rem but is $m\n"
1N/A if !ok ($m->bstr(),$rem->bstr());
1N/A # bmod() return agrees with set value?
1N/A print "# o $class $args[0] % $args[1] should be $m ($rem) but is $tmod\n"
1N/A if !ok ($tmod->bstr(),$m->bstr());
1N/A
1N/A }
1N/A }
1N/A