Commit | Line | Data |
3510b4a1 |
1 | #!./perl -w |
760ac839 |
2 | |
3510b4a1 |
3 | # use strict; |
4 | |
6e592b3a |
5 | print "1..54\n"; |
3510b4a1 |
6 | |
7 | my $test = 1; |
8 | |
9 | sub 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 |
31 | |
32 | # Verify that addition/subtraction properly upgrade to doubles. |
1eb770ff |
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 |
36 | my $a = 2147483647; |
37 | my $c=$a++; |
38 | ok ($a == 2147483648, $a); |
760ac839 |
39 | |
40 | $a = 2147483647; |
41 | $c=++$a; |
3510b4a1 |
42 | ok ($a == 2147483648, $a); |
760ac839 |
43 | |
44 | $a = 2147483647; |
45 | $a=$a+1; |
3510b4a1 |
46 | ok ($a == 2147483648, $a); |
760ac839 |
47 | |
48 | $a = -2147483648; |
49 | $c=$a--; |
3510b4a1 |
50 | ok ($a == -2147483649, $a); |
760ac839 |
51 | |
52 | $a = -2147483648; |
53 | $c=--$a; |
3510b4a1 |
54 | ok ($a == -2147483649, $a); |
760ac839 |
55 | |
56 | $a = -2147483648; |
57 | $a=$a-1; |
3510b4a1 |
58 | ok ($a == -2147483649, $a); |
9b0e499b |
59 | |
60 | $a = 2147483648; |
61 | $a = -$a; |
62 | $c=$a--; |
3510b4a1 |
63 | ok ($a == -2147483649, $a); |
9b0e499b |
64 | |
65 | $a = 2147483648; |
66 | $a = -$a; |
67 | $c=--$a; |
3510b4a1 |
68 | ok ($a == -2147483649, $a); |
9b0e499b |
69 | |
70 | $a = 2147483648; |
71 | $a = -$a; |
72 | $a=$a-1; |
3510b4a1 |
73 | ok ($a == -2147483649, $a); |
9b0e499b |
74 | |
75 | $a = 2147483648; |
76 | $b = -$a; |
77 | $c=$b--; |
3510b4a1 |
78 | ok ($b == -$a-1, $a); |
9b0e499b |
79 | |
80 | $a = 2147483648; |
81 | $b = -$a; |
82 | $c=--$b; |
3510b4a1 |
83 | ok ($b == -$a-1, $a); |
9b0e499b |
84 | |
85 | $a = 2147483648; |
86 | $b = -$a; |
87 | $b=$b-1; |
3510b4a1 |
88 | ok ($b == -(++$a), $a); |
89 | |
f9b9d3d6 |
90 | $a = undef; |
91 | ok ($a++ eq '0', do { $a=undef; $a++ }, "postinc undef returns '0'"); |
92 | |
93 | $a = undef; |
94 | ok (!defined($a--), do { $a=undef; $a-- }, "postdec undef returns undef"); |
95 | |
3510b4a1 |
96 | # Verify that shared hash keys become unshared. |
97 | |
98 | sub 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 | |
120 | my (%orig) = my (%inc) = my (%dec) = my (%postinc) = my (%postdec) |
121 | = (1 => 1, ab => "ab"); |
122 | my %up = (1=>2, ab => 'ac'); |
123 | my %down = (1=>0, ab => -1); |
124 | |
125 | foreach (keys %inc) { |
126 | my $ans = $up{$_}; |
127 | my $up; |
128 | eval {$up = ++$_}; |
129 | ok ((defined $up and $up eq $ans), $up, $@); |
130 | } |
131 | |
132 | check_same (\%orig, \%inc); |
133 | |
134 | foreach (keys %dec) { |
135 | my $ans = $down{$_}; |
136 | my $down; |
137 | eval {$down = --$_}; |
138 | ok ((defined $down and $down eq $ans), $down, $@); |
139 | } |
140 | |
141 | check_same (\%orig, \%dec); |
142 | |
143 | foreach (keys %postinc) { |
144 | my $ans = $postinc{$_}; |
145 | my $up; |
146 | eval {$up = $_++}; |
147 | ok ((defined $up and $up eq $ans), $up, $@); |
148 | } |
149 | |
150 | check_same (\%orig, \%postinc); |
151 | |
152 | foreach (keys %postdec) { |
153 | my $ans = $postdec{$_}; |
154 | my $down; |
155 | eval {$down = $_--}; |
156 | ok ((defined $down and $down eq $ans), $down, $@); |
157 | } |
158 | |
159 | check_same (\%orig, \%postdec); |
ef088171 |
160 | |
161 | { |
162 | no warnings 'uninitialized'; |
840378f5 |
163 | my ($x, $y); |
ef088171 |
164 | eval { |
165 | $y ="$x\n"; |
166 | ++$x; |
167 | }; |
168 | ok($x == 1, $x); |
169 | ok($@ eq '', $@); |
170 | |
840378f5 |
171 | my ($p, $q); |
ef088171 |
172 | eval { |
173 | $q ="$p\n"; |
174 | --$p; |
175 | }; |
176 | ok($p == -1, $p); |
177 | ok($@ eq '', $@); |
178 | } |
f4eee32f |
179 | |
180 | $a = 2147483648; |
181 | $c=--$a; |
182 | ok ($a == 2147483647, $a); |
183 | |
184 | |
185 | $a = 2147483648; |
186 | $c=$a--; |
187 | ok ($a == 2147483647, $a); |
679d6c4e |
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 |
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 | |
203 | sub check_some_code { |
204 | my ($start, $warn, $action, $description) = @_; |
205 | my $warn_line = ($warn ? 'use' : 'no') . " warnings 'imprecision';"; |
206 | my @warnings; |
207 | local $SIG{__WARN__} = sub {push @warnings, "@_"}; |
208 | |
209 | print "# checking $action under $warn_line\n"; |
210 | my $code = <<"EOC"; |
211 | $warn_line |
212 | my \$i = \$start; |
213 | for(0 .. 3) { |
214 | my \$a = $action; |
215 | } |
216 | 1; |
217 | EOC |
218 | eval $code or die "# $@\n$code"; |
219 | |
220 | if ($warn) { |
221 | unless (ok (scalar @warnings == 2, scalar @warnings)) { |
222 | print STDERR "# $_" foreach @warnings; |
223 | } |
224 | foreach (@warnings) { |
225 | unless (ok (/Lost precision when incrementing \d+/, $_)) { |
226 | print STDERR "# $_" |
227 | } |
228 | } |
229 | } else { |
230 | unless (ok (scalar @warnings == 0)) { |
231 | print STDERR "# @$_" foreach @warnings; |
232 | } |
233 | } |
234 | } |
235 | |
b68c599a |
236 | my $h_uv_max = 1 + (~0 >> 1); |
b88df990 |
237 | my $found; |
238 | for my $n (47..113) { |
239 | my $power_of_2 = 2**$n; |
240 | my $plus_1 = $power_of_2 + 1; |
241 | next if $plus_1 != $power_of_2; |
b68c599a |
242 | my ($start_p, $start_n); |
243 | if ($h_uv_max > $power_of_2 / 2) { |
244 | my $uv_max = 1 + 2 * (~0 >> 1); |
245 | # UV_MAX is 2**$something - 1, so subtract 1 to get the start value |
246 | $start_p = $uv_max - 1; |
247 | # whereas IV_MIN is -(2**$something), so subtract 2 |
248 | $start_n = -$h_uv_max + 2; |
249 | print "# Mantissa overflows at 2**$n ($power_of_2)\n"; |
250 | print "# But max UV ($uv_max) is greater so testing that\n"; |
251 | } else { |
252 | print "# Testing 2**$n ($power_of_2) which overflows the mantissa\n"; |
253 | $start_p = int($power_of_2 - 2); |
254 | $start_n = -$start_p; |
255 | my $check = $power_of_2 - 2; |
256 | die "Something wrong with our rounding assumptions: $check vs $start_p" |
257 | unless $start_p == $check; |
258 | } |
b88df990 |
259 | |
260 | foreach my $warn (0, 1) { |
261 | foreach (['++$i', 'pre-inc'], ['$i++', 'post-inc']) { |
b68c599a |
262 | check_some_code($start_p, $warn, @$_); |
b88df990 |
263 | } |
264 | foreach (['--$i', 'pre-dec'], ['$i--', 'post-dec']) { |
b68c599a |
265 | check_some_code($start_n, $warn, @$_); |
b88df990 |
266 | } |
267 | } |
268 | |
269 | $found = 1; |
270 | last; |
271 | } |
272 | die "Could not find a value which overflows the mantissa" unless $found; |
6e592b3a |
273 | |
274 | # these will segfault if they fail |
275 | |
276 | sub PVBM () { 'foo' } |
277 | { my $dummy = index 'foo', PVBM } |
278 | |
279 | ok (scalar eval { my $pvbm = PVBM; $pvbm++ }); |
280 | ok (scalar eval { my $pvbm = PVBM; $pvbm-- }); |
281 | ok (scalar eval { my $pvbm = PVBM; ++$pvbm }); |
282 | ok (scalar eval { my $pvbm = PVBM; --$pvbm }); |
283 | |