Move the require './test.pl' to the end of t/comp/hints.t
[p5sagit/p5-mst-13.2.git] / t / op / inc.t
1 #!./perl -w
2
3 # use strict;
4
5 print "1..54\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