[p5sagit/p5-mst-13.2.git] / lib / Math / BigInt / t / inf_nan.t

#!/usr/bin/perl -w

# test inf/NaN handling all in one place
# Thanx to Jarkko for the excellent explanations and the tables

use Test;
use strict;

BEGIN
  {
  chdir 't' if -d 't';
  unshift @INC, '../lib';
  }
BEGIN
  {
  $| = 1;	
  # to locate the testing files
  my $location = $0; $location =~ s/inf_nan.t//i;
  if ($ENV{PERL_CORE})
    {
    @INC = qw(../t/lib);                # testing with the core distribution
    }
  unshift @INC, '../lib';       # for testing manually
  if (-d 't')
    {
    chdir 't';
    require File::Spec;
    unshift @INC, File::Spec->catdir(File::Spec->updir, $location);
    }
  else
    {
    unshift @INC, $location;
    }
  print "# INC = @INC\n";

	        # values    groups   oprators   classes   tests 
  plan tests =>   7       * 6      * 5        * 4       * 2 +
                  7       * 6      * 2        * 4       * 1;		# bmod
  }

use Math::BigInt;
use Math::BigFloat;
use Math::BigInt::Subclass;
use Math::BigFloat::Subclass;

my @classes = 
  qw/Math::BigInt Math::BigFloat
     Math::BigInt::Subclass Math::BigFloat::Subclass
    /;

my (@args,$x,$y,$z);

# +
foreach (qw/
  -inf:-inf:-inf
  -1:-inf:-inf
  -0:-inf:-inf
  0:-inf:-inf
  1:-inf:-inf
  inf:-inf:NaN
  NaN:-inf:NaN

  -inf:-1:-inf
  -1:-1:-2
  -0:-1:-1
  0:-1:-1
  1:-1:0
  inf:-1:inf
  NaN:-1:NaN

  -inf:0:-inf
  -1:0:-1
  -0:0:0
  0:0:0
  1:0:1
  inf:0:inf
  NaN:0:NaN

  -inf:1:-inf
  -1:1:0
  -0:1:1
  0:1:1
  1:1:2
  inf:1:inf
  NaN:1:NaN

  -inf:inf:NaN
  -1:inf:inf
  -0:inf:inf
  0:inf:inf
  1:inf:inf
  inf:inf:inf
  NaN:inf:NaN

  -inf:NaN:NaN
  -1:NaN:NaN
  -0:NaN:NaN
  0:NaN:NaN
  1:NaN:NaN
  inf:NaN:NaN
  NaN:NaN:NaN
  /)
  {
  @args = split /:/,$_;
  for my $class (@classes)
    {
    $x = $class->new($args[0]);
    $y = $class->new($args[1]);
    $args[2] = '0' if $args[2] eq '-0';		# BigInt/Float hasn't got -0
    my $r = $x->badd($y);

    print "# x $class $args[0] + $args[1] should be $args[2] but is $x\n",
      if !ok ($x->bstr(),$args[2]);
    print "# r $class $args[0] + $args[1] should be $args[2] but is $r\n",
      if !ok ($x->bstr(),$args[2]);
    }
  }

# -
foreach (qw/
  -inf:-inf:NaN
  -1:-inf:inf
  -0:-inf:inf
  0:-inf:inf
  1:-inf:inf
  inf:-inf:inf
  NaN:-inf:NaN

  -inf:-1:-inf
  -1:-1:0
  -0:-1:1
  0:-1:1
  1:-1:2
  inf:-1:inf
  NaN:-1:NaN

  -inf:0:-inf
  -1:0:-1
  -0:0:-0
  0:0:0
  1:0:1
  inf:0:inf
  NaN:0:NaN

  -inf:1:-inf
  -1:1:-2
  -0:1:-1
  0:1:-1
  1:1:0
  inf:1:inf
  NaN:1:NaN

  -inf:inf:-inf
  -1:inf:-inf
  -0:inf:-inf
  0:inf:-inf
  1:inf:-inf
  inf:inf:NaN
  NaN:inf:NaN

  -inf:NaN:NaN
  -1:NaN:NaN
  -0:NaN:NaN
  0:NaN:NaN
  1:NaN:NaN
  inf:NaN:NaN
  NaN:NaN:NaN
  /)
  {
  @args = split /:/,$_;
  for my $class (@classes)
    {
    $x = $class->new($args[0]);
    $y = $class->new($args[1]);
    $args[2] = '0' if $args[2] eq '-0';		# BigInt/Float hasn't got -0
    my $r = $x->bsub($y);

    print "# x $class $args[0] - $args[1] should be $args[2] but is $x\n"
      if !ok ($x->bstr(),$args[2]);
    print "# r $class $args[0] - $args[1] should be $args[2] but is $r\n"
      if !ok ($r->bstr(),$args[2]);
    }
  }

# *
foreach (qw/
  -inf:-inf:inf
  -1:-inf:inf
  -0:-inf:NaN
  0:-inf:NaN
  1:-inf:-inf
  inf:-inf:-inf
  NaN:-inf:NaN

  -inf:-1:inf
  -1:-1:1
  -0:-1:0
  0:-1:-0
  1:-1:-1
  inf:-1:-inf
  NaN:-1:NaN

  -inf:0:NaN
  -1:0:-0
  -0:0:-0
  0:0:0
  1:0:0
  inf:0:NaN
  NaN:0:NaN

  -inf:1:-inf
  -1:1:-1
  -0:1:-0
  0:1:0
  1:1:1
  inf:1:inf
  NaN:1:NaN

  -inf:inf:-inf
  -1:inf:-inf
  -0:inf:NaN
  0:inf:NaN
  1:inf:inf
  inf:inf:inf
  NaN:inf:NaN

  -inf:NaN:NaN
  -1:NaN:NaN
  -0:NaN:NaN
  0:NaN:NaN
  1:NaN:NaN
  inf:NaN:NaN
  NaN:NaN:NaN
  /)
  {
  @args = split /:/,$_;
  for my $class (@classes)
    {
    $x = $class->new($args[0]);
    $y = $class->new($args[1]);
    $args[2] = '0' if $args[2] eq '-0';		# BigInt/Float hasn't got -0
    $args[2] = '0' if $args[2] eq '-0';	# BigInt hasn't got -0
    my $r = $x->bmul($y);

    print "# x $class $args[0] * $args[1] should be $args[2] but is $x\n"
      if !ok ($x->bstr(),$args[2]);
    print "# r $class $args[0] * $args[1] should be $args[2] but is $r\n"
      if !ok ($r->bstr(),$args[2]);
    }
  }

# /
foreach (qw/
  -inf:-inf:NaN
  -1:-inf:0
  -0:-inf:0
  0:-inf:-0
  1:-inf:-0
  inf:-inf:NaN
  NaN:-inf:NaN

  -inf:-1:inf
  -1:-1:1
  -0:-1:0
  0:-1:-0
  1:-1:-1
  inf:-1:-inf
  NaN:-1:NaN

  -inf:0:-inf
  -1:0:-inf
  -0:0:NaN
  0:0:NaN
  1:0:inf
  inf:0:inf
  NaN:0:NaN

  -inf:1:-inf
  -1:1:-1
  -0:1:-0
  0:1:0
  1:1:1
  inf:1:inf
  NaN:1:NaN

  -inf:inf:NaN
  -1:inf:-0
  -0:inf:-0
  0:inf:0
  1:inf:0
  inf:inf:NaN
  NaN:inf:NaN

  -inf:NaN:NaN
  -1:NaN:NaN
  -0:NaN:NaN
  0:NaN:NaN
  1:NaN:NaN
  inf:NaN:NaN
  NaN:NaN:NaN
  /)
  {
  @args = split /:/,$_;
  for my $class (@classes)
    {
    $x = $class->new($args[0]);
    $y = $class->new($args[1]);
    $args[2] = '0' if $args[2] eq '-0';		# BigInt/Float hasn't got -0

    my $t = $x->copy();
    my $tmod = $t->copy();

    # bdiv in scalar context
    my $r = $x->bdiv($y);
    print "# x $class $args[0] / $args[1] should be $args[2] but is $x\n"
      if !ok ($x->bstr(),$args[2]);
    print "# r $class $args[0] / $args[1] should be $args[2] but is $r\n"
      if !ok ($r->bstr(),$args[2]);

    # bmod and bdiv in list context
    my ($d,$rem) = $t->bdiv($y);

    # bdiv in list context
    print "# t $class $args[0] / $args[1] should be $args[2] but is $t\n"
      if !ok ($t->bstr(),$args[2]);
    print "# d $class $args[0] / $args[1] should be $args[2] but is $d\n"
      if !ok ($d->bstr(),$args[2]);
    
    # bmod
    my $m = $tmod->bmod($y);

    # bmod() agrees with bdiv?
    print "# m $class $args[0] % $args[1] should be $rem but is $m\n"
      if !ok ($m->bstr(),$rem->bstr());
    # bmod() return agrees with set value?
    print "# o $class $args[0] % $args[1] should be $m ($rem) but is $tmod\n"
      if !ok ($tmod->bstr(),$m->bstr());

    }
  }
Commit	Line	Data
b3abae2a	1	#!/usr/bin/perl -w
b3abae2a	2
13a12e00	3	# test inf/NaN handling all in one place
	4	# Thanx to Jarkko for the excellent explanations and the tables
	5
b3abae2a	6	use Test;
	7	use strict;
	8
	9	BEGIN
	10	{
b3abae2a	11	chdir 't' if -d 't';
	12	unshift @INC, '../lib';
	13	}
f9a08e12	14	BEGIN
	15	{
	16	$\| = 1;
	17	# to locate the testing files
	18	my $location = $0; $location =~ s/inf_nan.t//i;
	19	if ($ENV{PERL_CORE})
	20	{
	21	@INC = qw(../t/lib); # testing with the core distribution
	22	}
	23	unshift @INC, '../lib'; # for testing manually
	24	if (-d 't')
	25	{
	26	chdir 't';
	27	require File::Spec;
	28	unshift @INC, File::Spec->catdir(File::Spec->updir, $location);
	29	}
	30	else
	31	{
	32	unshift @INC, $location;
	33	}
	34	print "# INC = @INC\n";
	35
	36	# values groups oprators classes tests
	37	plan tests => 7 * 6 * 5 * 4 * 2 +
	38	7 * 6 * 2 * 4 * 1; # bmod
	39	}
b3abae2a	40
b3abae2a	41	use Math::BigInt;
13a12e00	42	use Math::BigFloat;
f9a08e12	43	use Math::BigInt::Subclass;
	44	use Math::BigFloat::Subclass;
	45
	46	my @classes =
	47	qw/Math::BigInt Math::BigFloat
	48	Math::BigInt::Subclass Math::BigFloat::Subclass
	49	/;
b3abae2a	50
	51	my (@args,$x,$y,$z);
	52
	53	# +
	54	foreach (qw/
	55	-inf:-inf:-inf
	56	-1:-inf:-inf
	57	-0:-inf:-inf
	58	0:-inf:-inf
	59	1:-inf:-inf
	60	inf:-inf:NaN
	61	NaN:-inf:NaN
	62
	63	-inf:-1:-inf
	64	-1:-1:-2
	65	-0:-1:-1
	66	0:-1:-1
	67	1:-1:0
	68	inf:-1:inf
	69	NaN:-1:NaN
	70
	71	-inf:0:-inf
	72	-1:0:-1
	73	-0:0:0
	74	0:0:0
	75	1:0:1
	76	inf:0:inf
	77	NaN:0:NaN
	78
	79	-inf:1:-inf
	80	-1:1:0
	81	-0:1:1
	82	0:1:1
	83	1:1:2
	84	inf:1:inf
	85	NaN:1:NaN
	86
	87	-inf:inf:NaN
	88	-1:inf:inf
	89	-0:inf:inf
	90	0:inf:inf
	91	1:inf:inf
	92	inf:inf:inf
	93	NaN:inf:NaN
	94
	95	-inf:NaN:NaN
	96	-1:NaN:NaN
	97	-0:NaN:NaN
	98	0:NaN:NaN
	99	1:NaN:NaN
	100	inf:NaN:NaN
	101	NaN:NaN:NaN
	102	/)
	103	{
	104	@args = split /:/,$_;
f9a08e12	105	for my $class (@classes)
13a12e00	106	{
	107	$x = $class->new($args[0]);
	108	$y = $class->new($args[1]);
	109	$args[2] = '0' if $args[2] eq '-0'; # BigInt/Float hasn't got -0
f9a08e12	110	my $r = $x->badd($y);
	111
	112	print "# x $class $args[0] + $args[1] should be $args[2] but is $x\n",
	113	if !ok ($x->bstr(),$args[2]);
	114	print "# r $class $args[0] + $args[1] should be $args[2] but is $r\n",
	115	if !ok ($x->bstr(),$args[2]);
13a12e00	116	}
b3abae2a	117	}
	118
	119	# -
	120	foreach (qw/
	121	-inf:-inf:NaN
	122	-1:-inf:inf
	123	-0:-inf:inf
	124	0:-inf:inf
	125	1:-inf:inf
	126	inf:-inf:inf
	127	NaN:-inf:NaN
	128
	129	-inf:-1:-inf
	130	-1:-1:0
	131	-0:-1:1
	132	0:-1:1
	133	1:-1:2
	134	inf:-1:inf
	135	NaN:-1:NaN
	136
	137	-inf:0:-inf
	138	-1:0:-1
	139	-0:0:-0
	140	0:0:0
	141	1:0:1
	142	inf:0:inf
	143	NaN:0:NaN
	144
	145	-inf:1:-inf
	146	-1:1:-2
	147	-0:1:-1
	148	0:1:-1
	149	1:1:0
	150	inf:1:inf
	151	NaN:1:NaN
	152
	153	-inf:inf:-inf
	154	-1:inf:-inf
	155	-0:inf:-inf
	156	0:inf:-inf
	157	1:inf:-inf
	158	inf:inf:NaN
	159	NaN:inf:NaN
	160
	161	-inf:NaN:NaN
	162	-1:NaN:NaN
	163	-0:NaN:NaN
	164	0:NaN:NaN
	165	1:NaN:NaN
	166	inf:NaN:NaN
	167	NaN:NaN:NaN
	168	/)
	169	{
	170	@args = split /:/,$_;
f9a08e12	171	for my $class (@classes)
13a12e00	172	{
	173	$x = $class->new($args[0]);
	174	$y = $class->new($args[1]);
	175	$args[2] = '0' if $args[2] eq '-0'; # BigInt/Float hasn't got -0
f9a08e12	176	my $r = $x->bsub($y);
	177
	178	print "# x $class $args[0] - $args[1] should be $args[2] but is $x\n"
	179	if !ok ($x->bstr(),$args[2]);
	180	print "# r $class $args[0] - $args[1] should be $args[2] but is $r\n"
	181	if !ok ($r->bstr(),$args[2]);
13a12e00	182	}
b3abae2a	183	}
	184
	185	# *
	186	foreach (qw/
	187	-inf:-inf:inf
	188	-1:-inf:inf
	189	-0:-inf:NaN
	190	0:-inf:NaN
	191	1:-inf:-inf
	192	inf:-inf:-inf
	193	NaN:-inf:NaN
	194
	195	-inf:-1:inf
	196	-1:-1:1
	197	-0:-1:0
	198	0:-1:-0
	199	1:-1:-1
	200	inf:-1:-inf
	201	NaN:-1:NaN
	202
	203	-inf:0:NaN
	204	-1:0:-0
	205	-0:0:-0
	206	0:0:0
	207	1:0:0
	208	inf:0:NaN
	209	NaN:0:NaN
	210
	211	-inf:1:-inf
	212	-1:1:-1
	213	-0:1:-0
	214	0:1:0
	215	1:1:1
	216	inf:1:inf
	217	NaN:1:NaN
	218
	219	-inf:inf:-inf
	220	-1:inf:-inf
	221	-0:inf:NaN
	222	0:inf:NaN
	223	1:inf:inf
	224	inf:inf:inf
	225	NaN:inf:NaN
	226
	227	-inf:NaN:NaN
	228	-1:NaN:NaN
	229	-0:NaN:NaN
	230	0:NaN:NaN
	231	1:NaN:NaN
	232	inf:NaN:NaN
	233	NaN:NaN:NaN
	234	/)
	235	{
	236	@args = split /:/,$_;
f9a08e12	237	for my $class (@classes)
13a12e00	238	{
	239	$x = $class->new($args[0]);
	240	$y = $class->new($args[1]);
	241	$args[2] = '0' if $args[2] eq '-0'; # BigInt/Float hasn't got -0
	242	$args[2] = '0' if $args[2] eq '-0'; # BigInt hasn't got -0
f9a08e12	243	my $r = $x->bmul($y);
	244
	245	print "# x $class $args[0] * $args[1] should be $args[2] but is $x\n"
	246	if !ok ($x->bstr(),$args[2]);
	247	print "# r $class $args[0] * $args[1] should be $args[2] but is $r\n"
	248	if !ok ($r->bstr(),$args[2]);
13a12e00	249	}
b3abae2a	250	}
	251
	252	# /
	253	foreach (qw/
	254	-inf:-inf:NaN
	255	-1:-inf:0
	256	-0:-inf:0
	257	0:-inf:-0
	258	1:-inf:-0
	259	inf:-inf:NaN
	260	NaN:-inf:NaN
	261
	262	-inf:-1:inf
	263	-1:-1:1
	264	-0:-1:0
	265	0:-1:-0
	266	1:-1:-1
	267	inf:-1:-inf
	268	NaN:-1:NaN
	269
	270	-inf:0:-inf
	271	-1:0:-inf
	272	-0:0:NaN
	273	0:0:NaN
	274	1:0:inf
	275	inf:0:inf
	276	NaN:0:NaN
	277
	278	-inf:1:-inf
	279	-1:1:-1
	280	-0:1:-0
	281	0:1:0
	282	1:1:1
	283	inf:1:inf
	284	NaN:1:NaN
	285
	286	-inf:inf:NaN
	287	-1:inf:-0
	288	-0:inf:-0
	289	0:inf:0
	290	1:inf:0
	291	inf:inf:NaN
	292	NaN:inf:NaN
	293
	294	-inf:NaN:NaN
	295	-1:NaN:NaN
	296	-0:NaN:NaN
	297	0:NaN:NaN
	298	1:NaN:NaN
	299	inf:NaN:NaN
	300	NaN:NaN:NaN
	301	/)
	302	{
	303	@args = split /:/,$_;
f9a08e12	304	for my $class (@classes)
13a12e00	305	{
	306	$x = $class->new($args[0]);
	307	$y = $class->new($args[1]);
	308	$args[2] = '0' if $args[2] eq '-0'; # BigInt/Float hasn't got -0
f9a08e12	309
	310	my $t = $x->copy();
	311	my $tmod = $t->copy();
	312
	313	# bdiv in scalar context
	314	my $r = $x->bdiv($y);
	315	print "# x $class $args[0] / $args[1] should be $args[2] but is $x\n"
	316	if !ok ($x->bstr(),$args[2]);
	317	print "# r $class $args[0] / $args[1] should be $args[2] but is $r\n"
	318	if !ok ($r->bstr(),$args[2]);
	319
	320	# bmod and bdiv in list context
	321	my ($d,$rem) = $t->bdiv($y);
	322
	323	# bdiv in list context
	324	print "# t $class $args[0] / $args[1] should be $args[2] but is $t\n"
	325	if !ok ($t->bstr(),$args[2]);
	326	print "# d $class $args[0] / $args[1] should be $args[2] but is $d\n"
	327	if !ok ($d->bstr(),$args[2]);
	328
	329	# bmod
	330	my $m = $tmod->bmod($y);
	331
	332	# bmod() agrees with bdiv?
	333	print "# m $class $args[0] % $args[1] should be $rem but is $m\n"
	334	if !ok ($m->bstr(),$rem->bstr());
	335	# bmod() return agrees with set value?
	336	print "# o $class $args[0] % $args[1] should be $m ($rem) but is $tmod\n"
	337	if !ok ($tmod->bstr(),$m->bstr());
	338
13a12e00	339	}
b3abae2a	340	}
b3abae2a	341