t/op/inc.t

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