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