| 1 | #!./perl -w |
| 2 | |
| 3 | # use strict; |
| 4 | |
| 5 | print "1..56\n"; |
| 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 | } |
| 31 | |
| 32 | # Verify that addition/subtraction properly upgrade to doubles. |
| 33 | # These tests are only significant on machines with 32 bit longs, |
| 34 | # and two's complement negation, but shouldn't fail anywhere. |
| 35 | |
| 36 | my $a = 2147483647; |
| 37 | my $c=$a++; |
| 38 | ok ($a == 2147483648, $a); |
| 39 | |
| 40 | $a = 2147483647; |
| 41 | $c=++$a; |
| 42 | ok ($a == 2147483648, $a); |
| 43 | |
| 44 | $a = 2147483647; |
| 45 | $a=$a+1; |
| 46 | ok ($a == 2147483648, $a); |
| 47 | |
| 48 | $a = -2147483648; |
| 49 | $c=$a--; |
| 50 | ok ($a == -2147483649, $a); |
| 51 | |
| 52 | $a = -2147483648; |
| 53 | $c=--$a; |
| 54 | ok ($a == -2147483649, $a); |
| 55 | |
| 56 | $a = -2147483648; |
| 57 | $a=$a-1; |
| 58 | ok ($a == -2147483649, $a); |
| 59 | |
| 60 | $a = 2147483648; |
| 61 | $a = -$a; |
| 62 | $c=$a--; |
| 63 | ok ($a == -2147483649, $a); |
| 64 | |
| 65 | $a = 2147483648; |
| 66 | $a = -$a; |
| 67 | $c=--$a; |
| 68 | ok ($a == -2147483649, $a); |
| 69 | |
| 70 | $a = 2147483648; |
| 71 | $a = -$a; |
| 72 | $a=$a-1; |
| 73 | ok ($a == -2147483649, $a); |
| 74 | |
| 75 | $a = 2147483648; |
| 76 | $b = -$a; |
| 77 | $c=$b--; |
| 78 | ok ($b == -$a-1, $a); |
| 79 | |
| 80 | $a = 2147483648; |
| 81 | $b = -$a; |
| 82 | $c=--$b; |
| 83 | ok ($b == -$a-1, $a); |
| 84 | |
| 85 | $a = 2147483648; |
| 86 | $b = -$a; |
| 87 | $b=$b-1; |
| 88 | ok ($b == -(++$a), $a); |
| 89 | |
| 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 | |
| 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); |
| 160 | |
| 161 | { |
| 162 | no warnings 'uninitialized'; |
| 163 | my ($x, $y); |
| 164 | eval { |
| 165 | $y ="$x\n"; |
| 166 | ++$x; |
| 167 | }; |
| 168 | ok($x == 1, $x); |
| 169 | ok($@ eq '', $@); |
| 170 | |
| 171 | my ($p, $q); |
| 172 | eval { |
| 173 | $q ="$p\n"; |
| 174 | --$p; |
| 175 | }; |
| 176 | ok($p == -1, $p); |
| 177 | ok($@ eq '', $@); |
| 178 | } |
| 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); |
| 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 | } |
| 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 | |
| 236 | my $h_uv_max = 1 + (~0 >> 1); |
| 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; |
| 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 | } |
| 259 | |
| 260 | foreach my $warn (0, 1) { |
| 261 | foreach (['++$i', 'pre-inc'], ['$i++', 'post-inc']) { |
| 262 | check_some_code($start_p, $warn, @$_); |
| 263 | } |
| 264 | foreach (['--$i', 'pre-dec'], ['$i--', 'post-dec']) { |
| 265 | check_some_code($start_n, $warn, @$_); |
| 266 | } |
| 267 | } |
| 268 | |
| 269 | $found = 1; |
| 270 | last; |
| 271 | } |
| 272 | die "Could not find a value which overflows the mantissa" unless $found; |
| 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 | |
| 284 | # #9466 |
| 285 | |
| 286 | # don't use pad TARG when the thing you're copying is a ref, or the referent |
| 287 | # won't get freed. |
| 288 | { |
| 289 | package P9466; |
| 290 | my $x; |
| 291 | sub DESTROY { $x = 1 } |
| 292 | for (0..1) { |
| 293 | $x = 0; |
| 294 | my $a = bless {}; |
| 295 | my $b = $_ ? $a++ : $a--; |
| 296 | undef $a; undef $b; |
| 297 | ::ok ($x, $x, "9466 case $_"); |
| 298 | } |
| 299 | } |