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