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