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