13 # Tests of post/pre - increment/decrement operators.
15 # Verify that addition/subtraction properly upgrade to doubles.
16 # These tests are only significant on machines with 32 bit longs,
17 # and two's complement negation, but shouldn't fail anywhere.
21 cmp_ok($a, '==', 2147483648, "postincrement properly upgrades to double");
25 cmp_ok($a, '==', 2147483648, "preincrement properly upgrades to double");
29 cmp_ok($a, '==', 2147483648, "addition properly upgrades to double");
33 cmp_ok($a, '==', -2147483649, "postdecrement properly upgrades to double");
37 cmp_ok($a, '==', -2147483649, "predecrement properly upgrades to double");
41 cmp_ok($a, '==', -2147483649, "subtraction properly upgrades to double");
46 cmp_ok($a, '==', -2147483649,
47 "negation and postdecrement properly upgrade to double");
52 cmp_ok($a, '==', -2147483649,
53 "negation and predecrement properly upgrade to double");
58 cmp_ok($a, '==', -2147483649,
59 "negation and subtraction properly upgrade to double");
64 cmp_ok($b, '==', -$a-1, "negation, postdecrement and additional negation");
69 cmp_ok($b, '==', -$a-1, "negation, predecrement and additional negation");
74 cmp_ok($b, '==', -(++$a),
75 "negation, subtraction, preincrement and additional negation");
78 is($a++, '0', "postinc undef returns '0'");
81 is($a--, undef, "postdec undef returns undef");
83 # Verify that shared hash keys become unshared.
86 my ($orig, $suspect) = @_;
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";
95 print "# key '$key' is '$orig->{$key}', unexpect.\n";
99 foreach (keys %$orig) {
100 next if (exists $suspect->{$_});
101 print "# key '$_' was '$orig->{$_}' now missing\n";
104 ok (!$fail, "original hashes unchanged");
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);
112 foreach (keys %inc) {
116 is($up, $ans, "key '$_' incremented correctly");
117 is($@, '', "no error condition");
120 check_same (\%orig, \%inc);
122 foreach (keys %dec) {
126 is($down, $ans, "key '$_' decremented correctly");
127 is($@, '', "no error condition");
130 check_same (\%orig, \%dec);
132 foreach (keys %postinc) {
133 my $ans = $postinc{$_};
136 is($up, $ans, "assignment preceded postincrement");
137 is($@, '', "no error condition");
140 check_same (\%orig, \%postinc);
142 foreach (keys %postdec) {
143 my $ans = $postdec{$_};
146 is($down, $ans, "assignment preceded postdecrement");
147 is($@, '', "no error condition");
150 check_same (\%orig, \%postdec);
153 no warnings 'uninitialized';
159 cmp_ok($x, '==', 1, "preincrement of previously uninitialized variable");
160 is($@, '', "no error condition");
167 cmp_ok($p, '==', -1, "predecrement of previously uninitialized variable");
168 is($@, '', "no error condition");
173 cmp_ok($a, '==', 2147483647, "predecrement properly downgrades from double");
178 cmp_ok($a, '==', 2147483647, "postdecrement properly downgrades from double");
184 cmp_ok($x, '==', 1, "(void) i_postinc");
186 cmp_ok($x, '==', 0, "(void) i_postdec");
190 if ($Config{uselongdouble} &&
191 ($Config{longdblkind} == 6 || $Config{longdoublekind} == 5)) {
192 skip "the double-double format is weird", 1;
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 :-)
200 my $h_uv_max = 1 + (~0 >> 1);
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;
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";
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;
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) = @$_;
229 my $code = eval << "EOC" or die $@;
231 no warnings 'imprecision';
239 warning_is($code, undef, "$description under no warnings 'imprecision'");
241 $code = eval << "EOC" or die $@;
243 use warnings 'imprecision';
251 warnings_like($code, [(qr/Lost precision when ${act}rementing -?\d+/) x 2],
252 "$description under use warnings 'imprecision'");
259 ok($found, "found a NV value which overflows the mantissa");
263 # these will segfault if they fail
265 sub PVBM () { 'foo' }
266 { my $dummy = index 'foo', PVBM }
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");
275 # don't use pad TARG when the thing you're copying is a ref, or the referent
280 sub DESTROY { $x = 1 }
284 my $b = $_ ? $a++ : $a--;
286 ::is($x, 1, "9466 case $_");
292 is($_, -1, 'regexp--');
294 no warnings 'numeric';
297 is($_, 1, 'regexp++');
302 isnt(ref\$_, 'VSTRING', '++ flattens vstrings');