t/op/inc.t

   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 }