1#!./perl 2 3# This file has been placed in t/opbasic to indicate that it should not use 4# functions imported from t/test.pl or Test::More, as those programs/libraries 5# use operators which are what is being tested in this file. 6 7# 2s complement assumption. Will not break test, just makes the internals of 8# the SVs less interesting if were not on 2s complement system. 9my $uv_max = ~0; 10my $uv_maxm1 = ~0 ^ 1; 11my $uv_big = $uv_max; 12$uv_big = ($uv_big - 20000) | 1; 13my ($iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, $iv_small); 14$iv_max = $uv_max; # Do copy, *then* divide 15$iv_max /= 2; 16$iv_min = $iv_max; 17{ 18 use integer; 19 $iv0 = 2 - 2; 20 $iv1 = 3 - 2; 21 $ivm1 = 2 - 3; 22 $iv_max -= 1; 23 $iv_min += 0; 24 $iv_big = $iv_max - 3; 25 $iv_small = $iv_min + 2; 26} 27my $uv_bigi = $iv_big; 28$uv_bigi |= 0x0; 29 30my @array = qw(perl rules); 31 32my @raw, @upgraded, @utf8; 33foreach ("\0", "\x{1F4A9}", chr(163), 'N') { 34 push @raw, $_; 35 my $temp = $_ . chr 256; 36 chop $temp; 37 push @upgraded, $temp; 38 my $utf8 = $_; 39 next if utf8::upgrade($utf8) == length $_; 40 utf8::encode($utf8); 41 push @utf8, $utf8; 42} 43 44# Seems one needs to perform the maths on 'Inf' to get the NV correctly primed. 45@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1, 3.14, 1e37, 0.632120558, -.5, 46 'Inf'+1, '-Inf'-1, 0x0, 0x1, 0x5, 0xFFFFFFFF, $uv_max, $uv_maxm1, 47 $uv_big, $uv_bigi, $iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, 48 $iv_small, \$array[0], \$array[0], \$array[1], \$^X, @raw, @upgraded, 49 @utf8); 50 51$expect = 7 * ($#FOO+2) * ($#FOO+1) + 6 * @raw + 6 * @utf8; 52print "1..$expect\n"; 53 54my $bad_NaN = 0; 55 56{ 57 # gcc -ffast-math option may stop NaNs working correctly 58 use Config; 59 my $ccflags = $Config{ccflags} // ''; 60 $bad_NaN = 1 if $ccflags =~ /-ffast-math\b/; 61} 62 63sub nok ($$$$$$$$) { 64 my ($test, $left, $threeway, $right, $result, $i, $j, $boolean) = @_; 65 $result = defined $result ? "'$result'" : 'undef'; 66 if ($bad_NaN && ($left eq 'NaN' || $right eq 'NaN')) { 67 print "ok $test # skipping failed NaN test under -ffast-math\n"; 68 } 69 else { 70 print "not ok $test # ($left $threeway $right) gives: $result \$i=$i \$j=$j, $boolean disagrees\n"; 71 } 72} 73 74my $ok = 0; 75for my $i (0..$#FOO) { 76 for my $j ($i..$#FOO) { 77 $ok++; 78 # Comparison routines may convert these internally, which would change 79 # what is used to determine the comparison on later runs. Hence copy 80 my ($i1, $i2, $i3, $i4, $i5, $i6, $i7, $i8, $i9, $i10, 81 $i11, $i12, $i13, $i14, $i15, $i16, $i17) = 82 ($FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], 83 $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], 84 $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i]); 85 my ($j1, $j2, $j3, $j4, $j5, $j6, $j7, $j8, $j9, $j10, 86 $j11, $j12, $j13, $j14, $j15, $j16, $j17) = 87 ($FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], 88 $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], 89 $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j]); 90 my $cmp = $i1 <=> $j1; 91 if (!defined($cmp) ? !($i2 < $j2) 92 : ($cmp == -1 && $i2 < $j2 || 93 $cmp == 0 && !($i2 < $j2) || 94 $cmp == 1 && !($i2 < $j2))) 95 { 96 print "ok $ok\n"; 97 } 98 else { 99 nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<'); 100 } 101 $ok++; 102 if (!defined($cmp) ? !($i4 == $j4) 103 : ($cmp == -1 && !($i4 == $j4) || 104 $cmp == 0 && $i4 == $j4 || 105 $cmp == 1 && !($i4 == $j4))) 106 { 107 print "ok $ok\n"; 108 } 109 else { 110 nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '=='); 111 } 112 $ok++; 113 if (!defined($cmp) ? !($i5 > $j5) 114 : ($cmp == -1 && !($i5 > $j5) || 115 $cmp == 0 && !($i5 > $j5) || 116 $cmp == 1 && ($i5 > $j5))) 117 { 118 print "ok $ok\n"; 119 } 120 else { 121 nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '>'); 122 } 123 $ok++; 124 if (!defined($cmp) ? !($i6 >= $j6) 125 : ($cmp == -1 && !($i6 >= $j6) || 126 $cmp == 0 && $i6 >= $j6 || 127 $cmp == 1 && $i6 >= $j6)) 128 { 129 print "ok $ok\n"; 130 } 131 else { 132 nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '>='); 133 } 134 $ok++; 135 # OK, so the docs are wrong it seems. NaN != NaN 136 if (!defined($cmp) ? ($i7 != $j7) 137 : ($cmp == -1 && $i7 != $j7 || 138 $cmp == 0 && !($i7 != $j7) || 139 $cmp == 1 && $i7 != $j7)) 140 { 141 print "ok $ok\n"; 142 } 143 else { 144 nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '!='); 145 } 146 $ok++; 147 if (!defined($cmp) ? !($i8 <= $j8) 148 : ($cmp == -1 && $i8 <= $j8 || 149 $cmp == 0 && $i8 <= $j8 || 150 $cmp == 1 && !($i8 <= $j8))) 151 { 152 print "ok $ok\n"; 153 } 154 else { 155 nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<='); 156 } 157 $ok++; 158 my $pmc = $j16 <=> $i16; # cmp it in reverse 159 # Should give -ve of other answer, or undef for NaNs 160 # a + -a should be zero. not zero is truth. which avoids using == 161 if (defined($cmp) ? !($cmp + $pmc) : !defined $pmc) 162 { 163 print "ok $ok\n"; 164 } 165 else { 166 nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<=> transposed'); 167 } 168 169 170 # String comparisons 171 $ok++; 172 $cmp = $i9 cmp $j9; 173 if ($cmp == -1 && $i10 lt $j10 || 174 $cmp == 0 && !($i10 lt $j10) || 175 $cmp == 1 && !($i10 lt $j10)) 176 { 177 print "ok $ok\n"; 178 } 179 else { 180 nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'lt'); 181 } 182 $ok++; 183 if ($cmp == -1 && !($i11 eq $j11) || 184 $cmp == 0 && ($i11 eq $j11) || 185 $cmp == 1 && !($i11 eq $j11)) 186 { 187 print "ok $ok\n"; 188 } 189 else { 190 nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'eq'); 191 } 192 $ok++; 193 if ($cmp == -1 && !($i12 gt $j12) || 194 $cmp == 0 && !($i12 gt $j12) || 195 $cmp == 1 && ($i12 gt $j12)) 196 { 197 print "ok $ok\n"; 198 } 199 else { 200 nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'gt'); 201 } 202 $ok++; 203 if ($cmp == -1 && $i13 le $j13 || 204 $cmp == 0 && ($i13 le $j13) || 205 $cmp == 1 && !($i13 le $j13)) 206 { 207 print "ok $ok\n"; 208 } 209 else { 210 nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'le'); 211 } 212 $ok++; 213 if ($cmp == -1 && ($i14 ne $j14) || 214 $cmp == 0 && !($i14 ne $j14) || 215 $cmp == 1 && ($i14 ne $j14)) 216 { 217 print "ok $ok\n"; 218 } 219 else { 220 nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'ne'); 221 } 222 $ok++; 223 if ($cmp == -1 && !($i15 ge $j15) || 224 $cmp == 0 && ($i15 ge $j15) || 225 $cmp == 1 && ($i15 ge $j15)) 226 { 227 print "ok $ok\n"; 228 } 229 else { 230 nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'ge'); 231 } 232 $ok++; 233 $pmc = $j17 cmp $i17; # cmp it in reverse 234 # Should give -ve of other answer 235 # a + -a should be zero. not zero is truth. which avoids using == 236 if (!($cmp + $pmc)) 237 { 238 print "ok $ok\n"; 239 } 240 else { 241 nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'cmp transposed'); 242 } 243 } 244} 245 246# We know the answers for these. We can rely on the consistency checks above 247# to test the other string comparisons. 248 249while (my ($i, $v) = each @raw) { 250 # Copy, to avoid any inadvertent conversion 251 my ($raw, $cooked, $not); 252 $raw = $v; 253 $cooked = $upgraded[$i]; 254 $not = $raw eq $cooked ? '' : 'not '; 255 printf "%sok %d # eq, chr %d\n", $not, ++$ok, ord $raw; 256 257 $raw = $v; 258 $cooked = $upgraded[$i]; 259 $not = $raw ne $cooked ? 'not ' : ''; 260 printf "%sok %d # ne, chr %d\n", $not, ++$ok, ord $raw; 261 262 $raw = $v; 263 $cooked = $upgraded[$i]; 264 $not = (($raw cmp $cooked) == 0) ? '' : 'not '; 265 printf "%sok %d # cmp, chr %d\n", $not, ++$ok, ord $raw; 266 267 # And now, transposed. 268 $raw = $v; 269 $cooked = $upgraded[$i]; 270 $not = $cooked eq $raw ? '' : 'not '; 271 printf "%sok %d # eq, chr %d\n", $not, ++$ok, ord $raw; 272 273 $raw = $v; 274 $cooked = $upgraded[$i]; 275 $not = $cooked ne $raw ? 'not ' : ''; 276 printf "%sok %d # ne, chr %d\n", $not, ++$ok, ord $raw; 277 278 $raw = $v; 279 $cooked = $upgraded[$i]; 280 $not = (($cooked cmp $raw) == 0) ? '' : 'not '; 281 printf "%sok %d # cmp, chr %d\n", $not, ++$ok, ord $raw; 282} 283 284while (my ($i, $v) = each @utf8) { 285 # Copy, to avoid any inadvertent conversion 286 my ($raw, $cooked, $not); 287 $raw = $raw[$i]; 288 $cooked = $v; 289 $not = $raw eq $cooked ? 'not ' : ''; 290 printf "%sok %d # eq vs octets, chr %d\n", $not, ++$ok, ord $raw; 291 292 $raw = $raw[$i]; 293 $cooked = $v; 294 $not = $raw ne $cooked ? '' : 'not '; 295 printf "%sok %d # ne vs octets, chr %d\n", $not, ++$ok, ord $raw; 296 297 $raw = $raw[$i]; 298 $cooked = $v; 299 $not = (($raw cmp $cooked) == 0) ? 'not ' : ''; 300 printf "%sok %d # cmp vs octects, chr %d\n", $not, ++$ok, ord $raw; 301 302 # And now, transposed. 303 $raw = $raw[$i]; 304 $cooked = $v; 305 $not = $cooked eq $raw ? 'not ' : ''; 306 printf "%sok %d # eq vs octets, chr %d\n", $not, ++$ok, ord $raw; 307 308 $raw = $raw[$i]; 309 $cooked = $v; 310 $not = $cooked ne $raw? '' : 'not '; 311 printf "%sok %d # ne vs octets, chr %d\n", $not, ++$ok, ord $raw; 312 313 $raw = $raw[$i]; 314 $cooked = $v; 315 $not = (($cooked cmp $raw) == 0) ? 'not ' : ''; 316 printf "%sok %d # cmp vs octects, chr %d\n", $not, ++$ok, ord $raw; 317} 318