1#!./perl 2 3# 4# test the conversion operators 5# 6# Notations: 7# 8# "N p i N vs N N": Apply op-N, then op-p, then op-i, then reporter-N 9# Compare with application of op-N, then reporter-N 10# Right below are descriptions of different ops and reporters. 11 12# We do not use these subroutines any more, sub overhead makes a "switch" 13# solution better: 14 15# obviously, 0, 1 and 2, 3 are destructive. (XXXX 64-bit? 4 destructive too) 16 17# *0 = sub {--$_[0]}; # - 18# *1 = sub {++$_[0]}; # + 19 20# # Converters 21# *2 = sub { $_[0] = $max_uv & $_[0]}; # U 22# *3 = sub { use integer; $_[0] += $zero}; # I 23# *4 = sub { $_[0] += $zero}; # N 24# *5 = sub { $_[0] = "$_[0]" }; # P 25 26# # Side effects 27# *6 = sub { $max_uv & $_[0]}; # u 28# *7 = sub { use integer; $_[0] + $zero}; # i 29# *8 = sub { $_[0] + $zero}; # n 30# *9 = sub { $_[0] . "" }; # p 31 32# # Reporters 33# sub a2 { sprintf "%u", $_[0] } # U 34# sub a3 { sprintf "%d", $_[0] } # I 35# sub a4 { sprintf "%g", $_[0] } # N 36# sub a5 { "$_[0]" } # P 37 38BEGIN { 39 chdir 't' if -d 't'; 40 @INC = '../lib'; 41} 42 43use strict 'vars'; 44 45my $max_chain = $ENV{PERL_TEST_NUMCONVERTS} || 2; 46 47# Bulk out if unsigned type is hopelessly wrong: 48my $max_uv1 = ~0; 49my $max_uv2 = sprintf "%u", $max_uv1 ** 6; # 6 is an arbitrary number here 50my $big_iv = do {use integer; $max_uv1 * 16}; # 16 is an arbitrary number here 51 52print "# max_uv1 = $max_uv1, max_uv2 = $max_uv2, big_iv = $big_iv\n"; 53if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1) { 54 print "1..0 # skipped: unsigned perl arithmetic is not sane"; 55 eval { require Config; import Config }; 56 use vars qw(%Config); 57 if ($Config{d_quad} eq 'define') { 58 print " (common in 64-bit platforms)"; 59 } 60 print "\n"; 61 exit 0; 62} 63 64my $st_t = 4*4; # We try 4 initializers and 4 reporters 65 66my $num = 0; 67$num += 10**$_ - 4**$_ for 1.. $max_chain; 68$num *= $st_t; 69print "1..$num\n"; # In fact 15 times more subsubtests... 70 71my $max_uv = ~0; 72my $max_iv = int($max_uv/2); 73my $zero = 0; 74 75my $l_uv = length $max_uv; 76my $l_iv = length $max_iv; 77 78# Hope: the first digits are good 79my $larger_than_uv = substr 97 x 100, 0, $l_uv; 80my $smaller_than_iv = substr 12 x 100, 0, $l_iv; 81my $yet_smaller_than_iv = substr 97 x 100, 0, ($l_iv - 1); 82 83my @list = (1, $yet_smaller_than_iv, $smaller_than_iv, $max_iv, $max_iv + 1, 84 $max_uv, $max_uv + 1); 85unshift @list, (reverse map -$_, @list), 0; # 15 elts 86@list = map "$_", @list; # Normalize 87 88# print "@list\n"; 89 90 91my @opnames = split //, "-+UINPuinp"; 92 93# @list = map { 2->($_), 3->($_), 4->($_), 5->($_), } @list; # Prepare input 94 95#print "@list\n"; 96#print "'@ops'\n"; 97 98my $test = 1; 99my $nok; 100for my $num_chain (1..$max_chain) { 101 my @ops = map [split //], grep /[4-9]/, 102 map { sprintf "%0${num_chain}d", $_ } 0 .. 10**$num_chain - 1; 103 104 #@ops = ([]) unless $num_chain; 105 #@ops = ([6, 4]); 106 107 # print "'@ops'\n"; 108 for my $op (@ops) { 109 for my $first (2..5) { 110 for my $last (2..5) { 111 $nok = 0; 112 my @otherops = grep $_ <= 3, @$op; 113 my @curops = ($op,\@otherops); 114 115 for my $num (@list) { 116 my $inpt; 117 my @ans; 118 119 for my $short (0, 1) { 120 # undef $inpt; # Forget all we had - some bugs were masked 121 122 $inpt = $num; # Try to not contaminate $num... 123 $inpt = "$inpt"; 124 if ($first == 2) { 125 $inpt = $max_uv & $inpt; # U 2 126 } elsif ($first == 3) { 127 use integer; $inpt += $zero; # I 3 128 } elsif ($first == 4) { 129 $inpt += $zero; # N 4 130 } else { 131 $inpt = "$inpt"; # P 5 132 } 133 134 # Saves 20% of time - not with this logic: 135 #my $tmp = $inpt; 136 #my $tmp1 = $num; 137 #next if $num_chain > 1 138 # and "$tmp" ne "$tmp1"; # Already the coercion gives problems... 139 140 for my $curop (@{$curops[$short]}) { 141 if ($curop < 5) { 142 if ($curop < 3) { 143 if ($curop == 0) { 144 --$inpt; # - 0 145 } elsif ($curop == 1) { 146 ++$inpt; # + 1 147 } else { 148 $inpt = $max_uv & $inpt; # U 2 149 } 150 } elsif ($curop == 3) { 151 use integer; $inpt += $zero; 152 } else { 153 $inpt += $zero; # N 4 154 } 155 } elsif ($curop < 8) { 156 if ($curop == 5) { 157 $inpt = "$inpt"; # P 5 158 } elsif ($curop == 6) { 159 $max_uv & $inpt; # u 6 160 } else { 161 use integer; $inpt + $zero; 162 } 163 } elsif ($curop == 8) { 164 $inpt + $zero; # n 8 165 } else { 166 $inpt . ""; # p 9 167 } 168 } 169 170 if ($last == 2) { 171 $inpt = sprintf "%u", $inpt; # U 2 172 } elsif ($last == 3) { 173 $inpt = sprintf "%d", $inpt; # I 3 174 } elsif ($last == 4) { 175 $inpt = sprintf "%g", $inpt; # N 4 176 } else { 177 $inpt = "$inpt"; # P 5 178 } 179 push @ans, $inpt; 180 } 181 $nok++, 182 print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n" 183 if $ans[0] ne $ans[1]; 184 } 185 print "not " if $nok; 186 print "ok $test\n"; 187 #print $txt if $nok; 188 $test++; 189 } 190 } 191 } 192} 193