10 my ($pass, $wrong, $err) = @_;
13 $test = $test + 1; # Would be doubleplusbad to use ++ in the ++ test.
18 print "not ok $test # $err\n";
21 $wrong = ", got $wrong";
25 printf "not ok $test # line %d$wrong\n", (caller)[2];
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.
38 ok ($a == 2147483648, $a);
42 ok ($a == 2147483648, $a);
46 ok ($a == 2147483648, $a);
50 ok ($a == -2147483649, $a);
54 ok ($a == -2147483649, $a);
58 ok ($a == -2147483649, $a);
63 ok ($a == -2147483649, $a);
68 ok ($a == -2147483649, $a);
73 ok ($a == -2147483649, $a);
88 ok ($b == -(++$a), $a);
91 ok ($a++ eq '0', do { $a=undef; $a++ }, "postinc undef returns '0'");
94 ok (!defined($a--), do { $a=undef; $a-- }, "postdec undef returns undef");
96 # Verify that shared hash keys become unshared.
99 my ($orig, $suspect) = @_;
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";
108 print "# key '$key' is '$orig->{$key}', unexpect.\n";
112 foreach (keys %$orig) {
113 next if (exists $suspect->{$_});
114 print "# key '$_' was '$orig->{$_}' now missing\n";
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);
125 foreach (keys %inc) {
129 ok ((defined $up and $up eq $ans), $up, $@);
132 check_same (\%orig, \%inc);
134 foreach (keys %dec) {
138 ok ((defined $down and $down eq $ans), $down, $@);
141 check_same (\%orig, \%dec);
143 foreach (keys %postinc) {
144 my $ans = $postinc{$_};
147 ok ((defined $up and $up eq $ans), $up, $@);
150 check_same (\%orig, \%postinc);
152 foreach (keys %postdec) {
153 my $ans = $postdec{$_};
156 ok ((defined $down and $down eq $ans), $down, $@);
159 check_same (\%orig, \%postdec);
162 no warnings 'uninitialized';
182 ok ($a == 2147483647, $a);
187 ok ($a == 2147483647, $a);
193 ok ($x == 1, "(void) i_postinc");
195 ok ($x == 0, "(void) i_postdec");
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 :-)
203 sub check_some_code {
204 my ($start, $warn, $action, $description) = @_;
205 my $warn_line = ($warn ? 'use' : 'no') . " warnings 'imprecision';";
207 local $SIG{__WARN__} = sub {push @warnings, "@_"};
209 print "# checking $action under $warn_line\n";
218 eval $code or die "# $@\n$code";
221 unless (ok (scalar @warnings == 2, scalar @warnings)) {
222 print STDERR "# $_" foreach @warnings;
224 foreach (@warnings) {
225 unless (ok (/Lost precision when incrementing \d+/, $_)) {
230 unless (ok (scalar @warnings == 0)) {
231 print STDERR "# @$_" foreach @warnings;
237 for my $n (47..113) {
238 my $power_of_2 = 2**$n;
239 my $plus_1 = $power_of_2 + 1;
240 next if $plus_1 != $power_of_2;
241 print "# Testing for 2**$n ($power_of_2) which overflows the mantissa\n";
242 # doing int here means that for NV > IV on the first go we're in the
243 # IV upgrade to NV case, and the second go we're in the NV already case.
244 my $start = int($power_of_2 - 2);
245 my $check = $power_of_2 - 2;
246 die "Something wrong with our rounding assumptions: $check vs $start"
247 unless $start == $check;
249 foreach my $warn (0, 1) {
250 foreach (['++$i', 'pre-inc'], ['$i++', 'post-inc']) {
251 check_some_code($start, $warn, @$_);
253 foreach (['--$i', 'pre-dec'], ['$i--', 'post-dec']) {
254 check_some_code(-$start, $warn, @$_);
261 die "Could not find a value which overflows the mantissa" unless $found;