Commit | Line | Data |
---|---|---|
3510b4a1 | 1 | #!./perl -w |
760ac839 | 2 | |
3ee2f9d8 JH |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
9224f6d1 | 5 | @INC = '../lib'; |
3ee2f9d8 JH |
6 | require './test.pl'; |
7 | } | |
8 | ||
faa5b915 | 9 | use strict; |
760ac839 | 10 | |
3ee2f9d8 JH |
11 | use Config; |
12 | ||
fc826e38 JK |
13 | # Tests of post/pre - increment/decrement operators. |
14 | ||
760ac839 | 15 | # Verify that addition/subtraction properly upgrade to doubles. |
1eb770ff | 16 | # These tests are only significant on machines with 32 bit longs, |
17 | # and two's complement negation, but shouldn't fail anywhere. | |
760ac839 | 18 | |
3510b4a1 NC |
19 | my $a = 2147483647; |
20 | my $c=$a++; | |
fc826e38 | 21 | cmp_ok($a, '==', 2147483648, "postincrement properly upgrades to double"); |
760ac839 LW |
22 | |
23 | $a = 2147483647; | |
24 | $c=++$a; | |
fc826e38 | 25 | cmp_ok($a, '==', 2147483648, "preincrement properly upgrades to double"); |
760ac839 LW |
26 | |
27 | $a = 2147483647; | |
28 | $a=$a+1; | |
fc826e38 | 29 | cmp_ok($a, '==', 2147483648, "addition properly upgrades to double"); |
760ac839 LW |
30 | |
31 | $a = -2147483648; | |
32 | $c=$a--; | |
fc826e38 | 33 | cmp_ok($a, '==', -2147483649, "postdecrement properly upgrades to double"); |
760ac839 LW |
34 | |
35 | $a = -2147483648; | |
36 | $c=--$a; | |
fc826e38 | 37 | cmp_ok($a, '==', -2147483649, "predecrement properly upgrades to double"); |
760ac839 LW |
38 | |
39 | $a = -2147483648; | |
40 | $a=$a-1; | |
fc826e38 | 41 | cmp_ok($a, '==', -2147483649, "subtraction properly upgrades to double"); |
9b0e499b GS |
42 | |
43 | $a = 2147483648; | |
44 | $a = -$a; | |
45 | $c=$a--; | |
fc826e38 JK |
46 | cmp_ok($a, '==', -2147483649, |
47 | "negation and postdecrement properly upgrade to double"); | |
9b0e499b GS |
48 | |
49 | $a = 2147483648; | |
50 | $a = -$a; | |
51 | $c=--$a; | |
fc826e38 JK |
52 | cmp_ok($a, '==', -2147483649, |
53 | "negation and predecrement properly upgrade to double"); | |
9b0e499b GS |
54 | |
55 | $a = 2147483648; | |
56 | $a = -$a; | |
57 | $a=$a-1; | |
fc826e38 JK |
58 | cmp_ok($a, '==', -2147483649, |
59 | "negation and subtraction properly upgrade to double"); | |
9b0e499b GS |
60 | |
61 | $a = 2147483648; | |
62 | $b = -$a; | |
63 | $c=$b--; | |
fc826e38 | 64 | cmp_ok($b, '==', -$a-1, "negation, postdecrement and additional negation"); |
9b0e499b GS |
65 | |
66 | $a = 2147483648; | |
67 | $b = -$a; | |
68 | $c=--$b; | |
fc826e38 | 69 | cmp_ok($b, '==', -$a-1, "negation, predecrement and additional negation"); |
9b0e499b GS |
70 | |
71 | $a = 2147483648; | |
72 | $b = -$a; | |
73 | $b=$b-1; | |
fc826e38 JK |
74 | cmp_ok($b, '==', -(++$a), |
75 | "negation, subtraction, preincrement and additional negation"); | |
3510b4a1 | 76 | |
f9b9d3d6 | 77 | $a = undef; |
faa5b915 | 78 | is($a++, '0', "postinc undef returns '0'"); |
f9b9d3d6 HS |
79 | |
80 | $a = undef; | |
faa5b915 | 81 | is($a--, undef, "postdec undef returns undef"); |
f9b9d3d6 | 82 | |
3510b4a1 NC |
83 | # Verify that shared hash keys become unshared. |
84 | ||
85 | sub check_same { | |
86 | my ($orig, $suspect) = @_; | |
87 | my $fail; | |
88 | while (my ($key, $value) = each %$suspect) { | |
89 | if (exists $orig->{$key}) { | |
90 | if ($orig->{$key} ne $value) { | |
91 | print "# key '$key' was '$orig->{$key}' now '$value'\n"; | |
92 | $fail = 1; | |
93 | } | |
94 | } else { | |
95 | print "# key '$key' is '$orig->{$key}', unexpect.\n"; | |
96 | $fail = 1; | |
97 | } | |
98 | } | |
99 | foreach (keys %$orig) { | |
100 | next if (exists $suspect->{$_}); | |
101 | print "# key '$_' was '$orig->{$_}' now missing\n"; | |
102 | $fail = 1; | |
103 | } | |
fc826e38 | 104 | ok (!$fail, "original hashes unchanged"); |
3510b4a1 NC |
105 | } |
106 | ||
107 | my (%orig) = my (%inc) = my (%dec) = my (%postinc) = my (%postdec) | |
108 | = (1 => 1, ab => "ab"); | |
109 | my %up = (1=>2, ab => 'ac'); | |
110 | my %down = (1=>0, ab => -1); | |
111 | ||
112 | foreach (keys %inc) { | |
113 | my $ans = $up{$_}; | |
114 | my $up; | |
115 | eval {$up = ++$_}; | |
fc826e38 JK |
116 | is($up, $ans, "key '$_' incremented correctly"); |
117 | is($@, '', "no error condition"); | |
3510b4a1 NC |
118 | } |
119 | ||
120 | check_same (\%orig, \%inc); | |
121 | ||
122 | foreach (keys %dec) { | |
123 | my $ans = $down{$_}; | |
124 | my $down; | |
125 | eval {$down = --$_}; | |
fc826e38 JK |
126 | is($down, $ans, "key '$_' decremented correctly"); |
127 | is($@, '', "no error condition"); | |
3510b4a1 NC |
128 | } |
129 | ||
130 | check_same (\%orig, \%dec); | |
131 | ||
132 | foreach (keys %postinc) { | |
133 | my $ans = $postinc{$_}; | |
134 | my $up; | |
135 | eval {$up = $_++}; | |
fc826e38 JK |
136 | is($up, $ans, "assignment preceded postincrement"); |
137 | is($@, '', "no error condition"); | |
3510b4a1 NC |
138 | } |
139 | ||
140 | check_same (\%orig, \%postinc); | |
141 | ||
142 | foreach (keys %postdec) { | |
143 | my $ans = $postdec{$_}; | |
144 | my $down; | |
145 | eval {$down = $_--}; | |
fc826e38 JK |
146 | is($down, $ans, "assignment preceded postdecrement"); |
147 | is($@, '', "no error condition"); | |
3510b4a1 NC |
148 | } |
149 | ||
150 | check_same (\%orig, \%postdec); | |
ef088171 NC |
151 | |
152 | { | |
153 | no warnings 'uninitialized'; | |
840378f5 | 154 | my ($x, $y); |
ef088171 NC |
155 | eval { |
156 | $y ="$x\n"; | |
157 | ++$x; | |
158 | }; | |
fc826e38 JK |
159 | cmp_ok($x, '==', 1, "preincrement of previously uninitialized variable"); |
160 | is($@, '', "no error condition"); | |
ef088171 | 161 | |
840378f5 | 162 | my ($p, $q); |
ef088171 NC |
163 | eval { |
164 | $q ="$p\n"; | |
165 | --$p; | |
166 | }; | |
fc826e38 JK |
167 | cmp_ok($p, '==', -1, "predecrement of previously uninitialized variable"); |
168 | is($@, '', "no error condition"); | |
ef088171 | 169 | } |
f4eee32f NC |
170 | |
171 | $a = 2147483648; | |
172 | $c=--$a; | |
fc826e38 | 173 | cmp_ok($a, '==', 2147483647, "predecrement properly downgrades from double"); |
f4eee32f NC |
174 | |
175 | ||
176 | $a = 2147483648; | |
177 | $c=$a--; | |
fc826e38 | 178 | cmp_ok($a, '==', 2147483647, "postdecrement properly downgrades from double"); |
679d6c4e HS |
179 | |
180 | { | |
181 | use integer; | |
182 | my $x = 0; | |
183 | $x++; | |
faa5b915 | 184 | cmp_ok($x, '==', 1, "(void) i_postinc"); |
679d6c4e | 185 | $x--; |
faa5b915 | 186 | cmp_ok($x, '==', 0, "(void) i_postdec"); |
679d6c4e | 187 | } |
b88df990 | 188 | |
3ee2f9d8 JH |
189 | SKIP: { |
190 | if ($Config{uselongdouble} && | |
b940ee07 | 191 | ($Config{longdblkind} == 6 || $Config{longdblkind} == 5)) { |
3ee2f9d8 JH |
192 | skip "the double-double format is weird", 1; |
193 | } | |
194 | ||
b88df990 NC |
195 | # I'm sure that there's an IBM format with a 48 bit mantissa |
196 | # IEEE doubles have a 53 bit mantissa | |
197 | # 80 bit long doubles have a 64 bit mantissa | |
198 | # sparcs have a 112 bit mantissa for their long doubles. Just to be awkward :-) | |
199 | ||
b68c599a | 200 | my $h_uv_max = 1 + (~0 >> 1); |
b88df990 NC |
201 | my $found; |
202 | for my $n (47..113) { | |
203 | my $power_of_2 = 2**$n; | |
204 | my $plus_1 = $power_of_2 + 1; | |
205 | next if $plus_1 != $power_of_2; | |
b68c599a NC |
206 | my ($start_p, $start_n); |
207 | if ($h_uv_max > $power_of_2 / 2) { | |
208 | my $uv_max = 1 + 2 * (~0 >> 1); | |
209 | # UV_MAX is 2**$something - 1, so subtract 1 to get the start value | |
210 | $start_p = $uv_max - 1; | |
211 | # whereas IV_MIN is -(2**$something), so subtract 2 | |
212 | $start_n = -$h_uv_max + 2; | |
213 | print "# Mantissa overflows at 2**$n ($power_of_2)\n"; | |
214 | print "# But max UV ($uv_max) is greater so testing that\n"; | |
215 | } else { | |
216 | print "# Testing 2**$n ($power_of_2) which overflows the mantissa\n"; | |
217 | $start_p = int($power_of_2 - 2); | |
218 | $start_n = -$start_p; | |
219 | my $check = $power_of_2 - 2; | |
220 | die "Something wrong with our rounding assumptions: $check vs $start_p" | |
221 | unless $start_p == $check; | |
222 | } | |
b88df990 | 223 | |
2353548e NC |
224 | foreach ([$start_p, '++$i', 'pre-inc', 'inc'], |
225 | [$start_p, '$i++', 'post-inc', 'inc'], | |
226 | [$start_n, '--$i', 'pre-dec', 'dec'], | |
227 | [$start_n, '$i--', 'post-dec', 'dec']) { | |
228 | my ($start, $action, $description, $act) = @$_; | |
faa5b915 NC |
229 | my $code = eval << "EOC" or die $@; |
230 | sub { | |
231 | no warnings 'imprecision'; | |
232 | my \$i = \$start; | |
233 | for(0 .. 3) { | |
234 | my \$a = $action; | |
235 | } | |
7db8714f | 236 | } |
7db8714f | 237 | EOC |
faa5b915 NC |
238 | |
239 | warning_is($code, undef, "$description under no warnings 'imprecision'"); | |
240 | ||
241 | $code = eval << "EOC" or die $@; | |
242 | sub { | |
243 | use warnings 'imprecision'; | |
244 | my \$i = \$start; | |
245 | for(0 .. 3) { | |
246 | my \$a = $action; | |
247 | } | |
248 | } | |
249 | EOC | |
250 | ||
251 | warnings_like($code, [(qr/Lost precision when ${act}rementing -?\d+/) x 2], | |
252 | "$description under use warnings 'imprecision'"); | |
b88df990 NC |
253 | } |
254 | ||
255 | $found = 1; | |
256 | last; | |
257 | } | |
8f1f21f6 JH |
258 | |
259 | ok($found, "found a NV value which overflows the mantissa"); | |
6e592b3a | 260 | |
3ee2f9d8 JH |
261 | } # SKIP |
262 | ||
6e592b3a BM |
263 | # these will segfault if they fail |
264 | ||
265 | sub PVBM () { 'foo' } | |
266 | { my $dummy = index 'foo', PVBM } | |
267 | ||
fc826e38 JK |
268 | isnt(scalar eval { my $pvbm = PVBM; $pvbm++ }, undef, "postincrement defined"); |
269 | isnt(scalar eval { my $pvbm = PVBM; $pvbm-- }, undef, "postdecrement defined"); | |
270 | isnt(scalar eval { my $pvbm = PVBM; ++$pvbm }, undef, "preincrement defined"); | |
271 | isnt(scalar eval { my $pvbm = PVBM; --$pvbm }, undef, "predecrement defined"); | |
6e592b3a | 272 | |
7dcb9b98 DM |
273 | # #9466 |
274 | ||
275 | # don't use pad TARG when the thing you're copying is a ref, or the referent | |
276 | # won't get freed. | |
277 | { | |
278 | package P9466; | |
279 | my $x; | |
280 | sub DESTROY { $x = 1 } | |
281 | for (0..1) { | |
282 | $x = 0; | |
283 | my $a = bless {}; | |
284 | my $b = $_ ? $a++ : $a--; | |
285 | undef $a; undef $b; | |
faa5b915 | 286 | ::is($x, 1, "9466 case $_"); |
7dcb9b98 DM |
287 | } |
288 | } | |
faa5b915 | 289 | |
b454703a FC |
290 | # *Do* use pad TARG if it is actually a named variable, even when the thing |
291 | # you’re copying is a ref. The fix for #9466 broke this. | |
292 | { | |
293 | package P9466_2; | |
294 | my $x; | |
295 | sub DESTROY { $x = 1 } | |
296 | for (2..3) { | |
297 | $x = 0; | |
298 | my $a = bless {}; | |
299 | my $b; | |
300 | use integer; | |
301 | if ($_ == 2) { | |
302 | $b = $a--; # sassign optimised away | |
303 | } | |
304 | else { | |
305 | $b = $a++; | |
306 | } | |
307 | ::is(ref $b, __PACKAGE__, 'i_post(in|de)c/TARGMY on ref'); | |
308 | undef $a; undef $b; | |
309 | ::is($x, 1, "9466 case $_"); | |
310 | } | |
311 | } | |
312 | ||
9bcf803b FC |
313 | $_ = ${qr //}; |
314 | $_--; | |
315 | is($_, -1, 'regexp--'); | |
3f7602fa TC |
316 | { |
317 | no warnings 'numeric'; | |
318 | $_ = ${qr //}; | |
319 | $_++; | |
320 | is($_, 1, 'regexp++'); | |
321 | } | |
376ccf8b | 322 | |
67d01233 KW |
323 | if ($::IS_EBCDIC) { |
324 | $_ = v129; | |
325 | $_++; | |
326 | isnt(ref\$_, 'VSTRING', '++ flattens vstrings'); | |
327 | } | |
328 | else { | |
329 | $_ = v97; | |
330 | $_++; | |
331 | isnt(ref\$_, 'VSTRING', '++ flattens vstrings'); | |
332 | } | |
9bcf803b | 333 | |
e87de4ab FC |
334 | sub TIESCALAR {bless\my $x} |
335 | sub STORE { ++$store::called } | |
336 | tie my $t, ""; | |
337 | { | |
338 | $t = $_++; | |
339 | $t = $_--; | |
340 | use integer; | |
341 | $t = $_++; | |
342 | $t = $_--; | |
343 | } | |
344 | is $store::called, 4, 'STORE called on "my" target'; | |
345 | ||
3baa0581 FC |
346 | { |
347 | # Temporarily broken between before 5.6.0 (b162f9ea/21f5b33c) and | |
348 | # between 5.21.5 and 5.21.6 (9e319cc4fd) | |
349 | my $x = 7; | |
350 | $x = $x++; | |
351 | is $x, 7, '$lex = $lex++'; | |
352 | $x = 7; | |
353 | # broken in b162f9ea (5.6.0); fixed in 5.21.6 | |
354 | use integer; | |
355 | $x = $x++; | |
356 | is $x, 7, '$lex = $lex++ under use integer'; | |
357 | } | |
358 | ||
faa5b915 | 359 | done_testing(); |