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; 7use strict; 8 9BEGIN 10 { 11 chdir 't' if -d 't'; 12 unshift @INC, '../lib'; 13 } 14BEGIN 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 operators classes tests 37 plan tests => 7 * 6 * 5 * 4 * 2 + 38 7 * 6 * 2 * 4 * 1; # bmod 39 } 40 41use Math::BigInt; 42use Math::BigFloat; 43use Math::BigInt::Subclass; 44use Math::BigFloat::Subclass; 45 46my @classes = 47 qw/Math::BigInt Math::BigFloat 48 Math::BigInt::Subclass Math::BigFloat::Subclass 49 /; 50 51my (@args,$x,$y,$z); 52 53# + 54foreach (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 /:/,$_; 105 for my $class (@classes) 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 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]); 116 } 117 } 118 119# - 120foreach (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 /:/,$_; 171 for my $class (@classes) 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 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]); 182 } 183 } 184 185# * 186foreach (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 /:/,$_; 237 for my $class (@classes) 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 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]); 249 } 250 } 251 252# / 253foreach (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 /:/,$_; 304 for my $class (@classes) 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 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 339 } 340 } 341 342