1#!perl 2 3use strict; 4use warnings; 5 6use Test::More tests => 60; 7 8use Math::BigFloat; 9 10my @k = (16, 32, 64, 128); 11 12sub stringify { 13 my $x = shift; 14 return "$x" unless $x -> is_finite(); 15 my $nstr = $x -> bnstr(); 16 my $sstr = $x -> bsstr(); 17 return length($nstr) < length($sstr) ? $nstr : $sstr; 18} 19 20for my $k (@k) { 21 22 # Parameters specific to this format: 23 24 my $b = 2; 25 my $p = $k == 16 ? 11 26 : $k == 32 ? 24 27 : $k == 64 ? 53 28 : $k - sprintf("%.0f", 4 * log($k)/log(2)) + 13; 29 30 $b = Math::BigFloat -> new($b); 31 $k = Math::BigFloat -> new($k); 32 $p = Math::BigFloat -> new($p); 33 my $w = $k - $p; 34 35 my $emax = 2 ** ($w - 1) - 1; 36 my $emin = 1 - $emax; 37 38 my $format = 'binary' . $k; 39 40 note("\nComputing test data for k = $k ...\n\n"); 41 42 my $binv = Math::BigFloat -> new("0.5"); 43 44 my $data = 45 [ 46 47 { 48 dsc => "smallest positive subnormal number", 49 bin => "0" 50 . ("0" x $w) 51 . ("0" x ($p - 2)) . "1", 52 asc => "$b ** ($emin) * $b ** (" . (1 - $p) . ") " 53 . "= $b ** (" . ($emin + 1 - $p) . ")", 54 mbf => $binv ** ($p - 1 - $emin), 55 }, 56 57 { 58 dsc => "largest subnormal number", 59 bin => "0" 60 . ("0" x $w) 61 . ("1" x ($p - 1)), 62 asc => "$b ** ($emin) * (1 - $b ** (" . (1 - $p) . "))", 63 mbf => $binv ** (-$emin) * (1 - $binv ** ($p - 1)), 64 }, 65 66 { 67 dsc => "smallest positive normal number", 68 bin => "0" 69 . ("0" x ($w - 1)) . "1" 70 . ("0" x ($p - 1)), 71 asc => "$b ** ($emin)", 72 mbf => $binv ** (-$emin), 73 }, 74 75 { 76 dsc => "largest normal number", 77 bin => "0" 78 . ("1" x ($w - 1)) . "0" 79 . "1" x ($p - 1), 80 asc => "$b ** $emax * ($b - $b ** (" . (1 - $p) . "))", 81 mbf => $b ** $emax * ($b - $binv ** ($p - 1)), 82 }, 83 84 { 85 dsc => "largest number less than one", 86 bin => "0" 87 . "0" . ("1" x ($w - 2)) . "0" 88 . "1" x ($p - 1), 89 asc => "1 - $b ** (-$p)", 90 mbf => 1 - $binv ** $p, 91 }, 92 93 { 94 dsc => "smallest number larger than one", 95 bin => "0" 96 . "0" . ("1" x ($w - 1)) 97 . ("0" x ($p - 2)) . "1", 98 asc => "1 + $b ** (" . (1 - $p) . ")", 99 mbf => 1 + $binv ** ($p - 1), 100 }, 101 102 { 103 dsc => "second smallest number larger than one", 104 bin => "0" 105 . "0" . ("1" x ($w - 1)) 106 . ("0" x ($p - 3)) . "10", 107 asc => "1 + $b ** (" . (2 - $p) . ")", 108 mbf => 1 + $binv ** ($p - 2), 109 }, 110 111 { 112 dsc => "one", 113 bin => "0" 114 . "0" . ("1" x ($w - 1)) 115 . "0" x ($p - 1), 116 asc => "1", 117 mbf => Math::BigFloat -> new("1"), 118 }, 119 120 { 121 dsc => "minus one", 122 bin => "1" 123 . "0" . ("1" x ($w - 1)) 124 . "0" x ($p - 1), 125 asc => "-1", 126 mbf => Math::BigFloat -> new("-1"), 127 }, 128 129 { 130 dsc => "two", 131 bin => "0" 132 . "1" . ("0" x ($w - 1)) 133 . ("0" x ($p - 1)), 134 asc => "2", 135 mbf => Math::BigFloat -> new("2"), 136 }, 137 138 { 139 dsc => "minus two", 140 bin => "1" 141 . "1" . ("0" x ($w - 1)) 142 . ("0" x ($p - 1)), 143 asc => "-2", 144 mbf => Math::BigFloat -> new("-2"), 145 }, 146 147 { 148 dsc => "positive zero", 149 bin => "0" 150 . ("0" x $w) 151 . ("0" x ($p - 1)), 152 asc => "+0", 153 mbf => Math::BigFloat -> new("0"), 154 }, 155 156 { 157 dsc => "positive infinity", 158 bin => "0" 159 . ("1" x $w) 160 . ("0" x ($p - 1)), 161 asc => "+inf", 162 mbf => Math::BigFloat -> new("inf"), 163 }, 164 165 { 166 dsc => "negative infinity", 167 bin => "1" 168 . ("1" x $w) 169 . ("0" x ($p - 1)), 170 asc => "-inf", 171 mbf => Math::BigFloat -> new("-inf"), 172 }, 173 174 { 175 dsc => "NaN (encoding used by Perl on Cygwin)", 176 bin => "1" 177 . ("1" x $w) 178 . ("1" . ("0" x ($p - 2))), 179 asc => "NaN", 180 mbf => Math::BigFloat -> new("NaN"), 181 }, 182 183 ]; 184 185 for my $entry (@$data) { 186 my $bin = $entry -> {bin}; 187 my $bytes = pack "B*", $bin; 188 my $hex = unpack "H*", $bytes; 189 190 note("\n", $entry -> {dsc}, " (k = $k): ", $entry -> {asc}, "\n\n"); 191 192 my $x = Math::BigFloat -> new($entry -> {mbf}); 193 194 my $test = qq|Math::BigFloat -> new("| . stringify($x) 195 . qq|") -> to_ieee754("$format")|; 196 197 my $got_bytes = $x -> to_ieee754($format); 198 my $got_hex = unpack "H*", $got_bytes; 199 $got_hex =~ s/(..)/\\x$1/g; 200 201 my $expected_hex = $hex; 202 $expected_hex =~ s/(..)/\\x$1/g; 203 204 is($got_hex, $expected_hex); 205 } 206} 207