File Coverage

blib/lib/Math/NV.pm
Criterion Covered Total %
statement 30 102 29.4
branch 4 48 8.3
condition n/a
subroutine 8 12 66.6
pod 0 7 0.0
total 42 169 24.8


line stmt bran cond sub pod time code
1             ## This file generated by InlineX::C2XS (version 0.22) using Inline::C (version 0.53)
2             package Math::NV;
3 8     8   4848 use warnings;
  8         15  
  8         219  
4 8     8   36 use strict;
  8         11  
  8         145  
5 8     8   196 use 5.010;
  8         22  
6              
7             require Exporter;
8             *import = \&Exporter::import;
9             require DynaLoader;
10              
11             $Math::NV::VERSION = '1.0';
12              
13             DynaLoader::bootstrap Math::NV $Math::NV::VERSION;
14              
15             @Math::NV::EXPORT = ();
16             @Math::NV::EXPORT_OK = qw(
17             nv nv_type mant_dig ld2binary ld_str2binary is_eq
18             bin2val Cprintf Csprintf nv_mpfr is_eq_mpfr
19             );
20              
21             %Math::NV::EXPORT_TAGS = (all => [qw(
22             nv nv_type mant_dig ld2binary ld_str2binary is_eq
23             bin2val Cprintf Csprintf nv_mpfr is_eq_mpfr
24             )]);
25              
26             eval {require Math::MPFR;};
27              
28             if($@) {$Math::NV::no_mpfr = $@}
29             else {$Math::NV_no_mpfr = 0 }
30              
31             $Math::NV::no_warn = 0; # set to true to disable warning about non-string argument
32              
33             # %_itsa is utilised in the formulation of the diagnostic message
34             # when it's detected that the provided arg is not a string.
35              
36             my %_itsa = (
37             1 => 'UV',
38             2 => 'IV',
39             3 => 'NV',
40             4 => 'string',
41             0 => 'unknown',
42             );
43              
44 8     8 0 2076 sub dl_load_flags {0} # Prevent DynaLoader from complaining and croaking
45              
46             sub ld2binary {
47 1     1 0 39 my @ret = _ld2binary($_[0]);
48 1         3 my $prec = pop(@ret);
49 1         2 my $exp = pop(@ret);
50 1         4 my $mantissa = join '', @ret;
51 1         5 return ($mantissa, $exp, $prec);
52             }
53              
54             sub ld_str2binary {
55 1     1 0 45 my @ret = _ld_str2binary($_[0]);
56 1         3 my $prec = pop(@ret);
57 1         2 my $exp = pop(@ret);
58 1         3 my $mantissa = join '', @ret;
59 1         5 return ($mantissa, $exp, $prec);
60             }
61              
62             sub bin2val {
63 1     1 0 22 my($mantissa, $exp, $prec) = (shift, shift, shift);
64 1 50       5 my $sign = $mantissa =~ /^\-/ ? '-' : '';
65             # Remove everything upto and including the radix point
66             # as it now contains no useful information.
67 1         6 $mantissa =~ s/.+\.//;
68             # For our purposes the values $prec and $exp need
69             # to be reduced by 1.
70 1         2 $exp--;
71              
72             # Perl bugs make the following (commented out) code unreliable,
73             # so we now hand the calculations over to C.
74             # (And there's no need to decrement $prec.)
75             #$prec--;
76             #for(0..$prec) {
77             # if(substr($mantissa, $_, 1)) {$val += 2**$exp}
78             # $exp--;
79             #}
80 1         8 my @mantissa = split //, $mantissa;
81 1         20 my $val = _bin2val($prec, $exp, \@mantissa);
82 1 50       7 $sign eq '-' ? return -$val : return $val;
83             }
84              
85             sub is_eq {
86 1 50   1 0 26 unless($Math::NV::no_warn) {
87 0         0 my $itsa = $_[0];
88 0         0 $itsa = _itsa($itsa); # make sure that $_[0] IOK flag is not set
89 0 0       0 warn "Argument given to is_eq() is $_itsa{$itsa}, not a string - probably not what you want"
90             if $itsa != 4;
91             }
92 1         2 my $nv = $_[0];
93 1         83 my $check = nv($_[0]);
94 1 50       6 return 1 if $nv == $check;
95 0 0         if(mant_dig() == 64) {
96             # pack/unpack like to deliver irrelevant (ie ignored) leading bytes
97             # if NV is 80-bit long double
98 0           my $first = scalar(reverse(unpack("h*", pack("F<", $nv))));
99 0           $first = substr($first, length($first) - 20, 20);
100 0           my $second = scalar(reverse(unpack("h*", pack("F<", $check))));
101 0           $second = substr($second, length($second) - 20, 20);
102 0           warn "In is_eq:\n$first vs $second\n\n";
103             }
104             else {
105 0           warn "In is_eq:\n",
106             scalar(reverse(unpack("h*", pack("F<", $nv)))), " vs ",
107             scalar(reverse(unpack("h*", pack("F<", $check)))), "\n\n";
108             }
109              
110 0           return 0;
111             }
112              
113             sub is_eq_mpfr {
114              
115 0 0   0 0   if($Math::NV::no_mpfr) {die "In is_eq_mpfr(): $Math::NV::no_mpfr"}
  0            
116              
117 0 0         unless($Math::NV::no_warn) {
118 0           my $itsa = $_[0];
119 0           $itsa = _itsa($itsa); # make sure that $_[0] IOK flag is not set
120 0 0         warn "Argument given to is_eq() is $_itsa{$itsa}, not a string - probably not what you want"
121             if $itsa != 4;
122             }
123              
124 0           my $ret = 0;
125 0           my $nv = $_[0];
126 0           my $bits = mant_dig();
127 0 0         $bits = 2098 if $bits == 106; # double double
128              
129 0           my $fr = Math::MPFR::Rmpfr_init2($bits);
130 0           Math::MPFR::Rmpfr_set_str($fr, $nv, 10, 0);
131              
132 0 0         if($nv == Math::MPFR::Rmpfr_get_NV($fr, 0)) {$ret = 1}
  0            
133             else {
134 0 0         if($bits == 64) {
135             # pack/unpack like to deliver irrelevant (ie ignored) leading bytes
136             # if NV is 80-bit long double
137 0           my $first = scalar(reverse(unpack("h*", pack("F<", $nv))));
138 0           $first = substr($first, length($first) - 20, 20);
139 0           my $second = scalar(reverse(unpack("h*", pack("F<", Math::MPFR::Rmpfr_get_NV($fr, 0)))));
140 0           $second = substr($second, length($second) - 20, 20);
141 0           warn "In is_eq_mpfr:\n$first vs $second\n\n";
142             }
143             else {
144 0           warn "In is_eq_mpfr:\n",
145             scalar(reverse(unpack("h*", pack("F<", $nv)))), " vs ",
146             scalar(reverse(unpack("h*", pack("F<", Math::MPFR::Rmpfr_get_NV($fr, 0))))), "\n\n";
147             }
148             }
149              
150 0           return $ret;
151              
152             }
153              
154             sub nv_mpfr {
155              
156 0 0   0 0   if($Math::NV::no_mpfr) {die "In nv_mpfr(): $Math::NV::no_mpfr"}
  0            
157              
158 0 0         unless($Math::NV::no_warn) {
159 0           my $itsa = $_[0];
160 0           $itsa = _itsa($itsa); # make sure that $_[0] IOK flag is not set
161 0 0         warn "Argument given to is_eq() is $_itsa{$itsa}, not a string - probably not what you want"
162             if $itsa != 4;
163             }
164              
165 0           my $bits;
166              
167 0 0         if(!defined($_[1])) {$bits = mant_dig()}
  0            
168 0           else {$bits = $_[1]}
169              
170 0 0         return _double_double($_[0]) if $bits == 106; # doubledouble
171              
172 0           my $val = Math::MPFR::Rmpfr_init2($bits);
173 0           Math::MPFR::Rmpfr_set_str($val, $_[0], 10, 0);
174              
175 0 0         if($bits == mant_dig() ) { # 53, 64, 106 or 113 bits
176 0           my $nv = Math::MPFR::Rmpfr_get_NV($val, 0);
177 0           my $ret = scalar(reverse(unpack("h*", pack("F<", $nv))));
178              
179             # pack/unpack like to deliver irrelevant (ie ignored) leading bytes
180             # if NV is 80-bit long double
181 0 0         if($bits == 64) {
182 0           return substr($ret, length($ret) - 20, 20);
183             }
184 0           return $ret;
185             }
186              
187 0 0         if($bits == 53) {
188 0           my $nv = Math::MPFR::Rmpfr_get_d($val, 0);
189 0           return scalar(reverse(unpack("h*", pack("d<", $nv))));
190             }
191              
192 0 0         if($bits == 64) {
193 0 0         die "No _ld_bytes with this version ($Math::MPFR::VERSION) - need at least 3.27"
194             unless $Math::MPFR::VERSION > '3.26';
195 0           my @bytes = Math::MPFR::_ld_bytes($_[0], 64);
196 0           return join('', @bytes);
197             }
198              
199 0 0         if($bits == 113) {
200 0 0         die "No _f128_bytes with this version ($Math::MPFR::VERSION) - need at least 3.26"
201             unless $Math::MPFR::VERSION > 3.25;
202 0           my @bytes = Math::MPFR::_f128_bytes($_[0], 113);
203 0           return join('', @bytes);
204             }
205              
206 0           die "Unrecognized value for bits ($bits)";
207             }
208              
209              
210             sub _double_double {
211 0     0     my $val = Math::MPFR::Rmpfr_init2(2098);
212 0           Math::MPFR::Rmpfr_set_str($val, shift, 10, 0);
213 0           my @val = _dd_obj($val);
214 0           return [scalar(reverse(unpack("h*", pack("d<", $val[0])))),
215             scalar(reverse(unpack("h*", pack("d<", $val[1]))))];
216             }
217              
218             sub _dd_obj {
219 0     0     my $obj = shift;
220 0           my $msd = Math::MPFR::Rmpfr_get_d($obj, 0);
221 0           $obj -= $msd;
222 0           return ($msd, Math::MPFR::Rmpfr_get_d($obj, 0));
223             }
224              
225              
226             1;
227              
228             __END__