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